rtables coverage - 90.20%

Files
Source

match_extra_args <- function(f,
                             .N_col,
                             .N_total,
                             .all_col_exprs,
                             .all_col_counts,
                             .var,
                             .ref_group = NULL,
                             .alt_df_row = NULL,
                             .alt_df = NULL,
                             .ref_full = NULL,
                             .in_ref_col = NULL,
                             .spl_context = NULL,
                             .N_row,
                             .df_row,
                             extras) {
  # This list is always present
  possargs <- c(
    list(
      .N_col = .N_col,
      .N_total = .N_total,
      .N_row = .N_row,
      .df_row = .df_row,
      .all_col_exprs = .all_col_exprs,
      .all_col_counts = .all_col_counts
    ),
    extras
  )

  ## specialized arguments that must be named in formals, cannot go
  ## anonymously into ...
  if (!is.null(.var) && nzchar(.var)) {
    possargs <- c(possargs, list(.var = .var))
  }
  if (!is.null(.ref_group)) {
    possargs <- c(possargs, list(.ref_group = .ref_group))
  }
  if (!is.null(.alt_df_row)) {
    possargs <- c(possargs, list(.alt_df_row = .alt_df_row))
  }
  if (!is.null(.alt_df)) {
    possargs <- c(possargs, list(.alt_df = .alt_df))
  }
  if (!is.null(.ref_full)) {
    possargs <- c(possargs, list(.ref_full = .ref_full))
  }
  if (!is.null(.in_ref_col)) {
    possargs <- c(possargs, list(.in_ref_col = .in_ref_col))
  }

  # Special case: .spl_context
  if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) {
    possargs <- c(possargs, list(.spl_context = .spl_context))
  } else {
    possargs$.spl_context <- NULL
  }

  # Extra args handling
  formargs <- formals(f)
  formnms <- names(formargs)
  exnms <- names(extras)
  if (is.null(formargs)) {
    return(NULL)
  } else if ("..." %in% names(formargs)) {
    formnms <- c(formnms, exnms[nzchar(exnms)])
  }
  possargs[names(possargs) %in% formnms]
}

#' @noRd
#' @return A `RowsVerticalSection` object representing the `k x 1` section of the
#'   table being generated, with `k` the number of rows the analysis function
#'   generates.
gen_onerv <- function(csub, col, count, cextr, cpath,
                      dfpart, func, totcount, splextra,
                      all_col_exprs,
                      all_col_counts,
                      takesdf = .takes_df(func),
                      baselinedf,
                      alt_dfpart,
                      inclNAs,
                      col_parent_inds,
                      spl_context) {
  if (NROW(spl_context) > 0) {
    spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".")
    spl_context$cur_col_subset <- col_parent_inds
    spl_context$cur_col_expr <- list(csub)
    spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L)
    spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)])
    spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)])
  }

  # Making .alt_df from alt_dfpart (i.e. .alt_df_row)
  if (NROW(alt_dfpart) > 0) {
    alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE]
    if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) {
      alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), ,
        drop = FALSE
      ]
    }
  } else {
    alt_dfpart_fil <- alt_dfpart
  }

  ## workaround for https://github.com/insightsengineering/rtables/issues/159
  if (NROW(dfpart) > 0) {
    inds <- eval(csub, envir = dfpart)
    dat <- dfpart[inds, , drop = FALSE]
  } else {
    dat <- dfpart
  }
  if (!is.null(col) && !inclNAs) {
    dat <- dat[!is.na(dat[[col]]), , drop = FALSE]
  }

  fullrefcoldat <- cextr$.ref_full
  if (!is.null(fullrefcoldat)) {
    cextr$.ref_full <- NULL
  }
  inrefcol <- cextr$.in_ref_col
  if (!is.null(fullrefcoldat)) {
    cextr$.in_ref_col <- NULL
  }

  exargs <- c(cextr, splextra)

  ## behavior for x/df and ref-data (full and group)
  ## match
  if (!is.null(col) && !takesdf) {
    dat <- dat[[col]]
    fullrefcoldat <- fullrefcoldat[[col]]
    baselinedf <- baselinedf[[col]]
  }
  args <- list(dat)

  names(all_col_counts) <- names(all_col_exprs)

  exargs <- match_extra_args(func,
    .N_col = count,
    .N_total = totcount,
    .all_col_exprs = all_col_exprs,
    .all_col_counts = all_col_counts,
    .var = col,
    .ref_group = baselinedf,
    .alt_df_row = alt_dfpart,
    .alt_df = alt_dfpart_fil,
    .ref_full = fullrefcoldat,
    .in_ref_col = inrefcol,
    .N_row = NROW(dfpart),
    .df_row = dfpart,
    .spl_context = spl_context,
    extras = c(
      cextr,
      splextra
    )
  )

  args <- c(args, exargs)

  val <- do.call(func, args)
  if (!is(val, "RowsVerticalSection")) {
    if (!is(val, "list")) {
      val <- list(val)
    }
    ret <- in_rows(
      .list = val,
      .labels = unlist(value_labels(val)),
      .names = names(val)
    )
  } else {
    ret <- val
  }
  ret
}

strip_multivar_suffix <- function(x) {
  gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x)
}

## Generate all values (one for each column) for one or more rows
## by calling func once per column (as defined by cinfo)
#' @noRd
#' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table.
gen_rowvalues <- function(dfpart,
                          datcol,
                          cinfo,
                          func,
                          splextra,
                          takesdf = NULL,
                          baselines,
                          alt_dfpart,
                          inclNAs,
                          spl_context = spl_context) {
  colexprs <- col_exprs(cinfo)
  colcounts <- col_counts(cinfo)
  colextras <- col_extra_args(cinfo, NULL)
  cpaths <- col_paths(cinfo)
  ## XXX I don't think this is used anywhere???
  ## splextra = c(splextra, list(.spl_context = spl_context))
  totcount <- col_total(cinfo)

  colleaves <- collect_leaves(cinfo@tree_layout)

  gotflist <- is.list(func)

  ## one set of named args to be applied to all columns
  if (!is.null(names(splextra))) {
    splextra <- list(splextra)
  } else {
    length(splextra) <- ncol(cinfo)
  }

  if (!gotflist) {
    func <- list(func)
  } else if (length(splextra) == 1) {
    splextra <- rep(splextra, length.out = length(func))
  }
  ## if(length(func)) == 1 && names(spl)
  ##     splextra = list(splextra)

  ## we are in analyze_colvars, so we have to match
  ## the exargs value by position for each column repeatedly
  ## across the higher level col splits.
  if (!is.null(datcol) && is.na(datcol)) {
    datcol <- character(length(colleaves))
    exargs <- vector("list", length(colleaves))
    for (i in seq_along(colleaves)) {
      x <- colleaves[[i]]

      pos <- tree_pos(x)
      spls <- pos_splits(pos)
      ## values have the suffix but we are populating datacol
      ## so it has to match var numbers so strip the suffixes back off
      splvals <- strip_multivar_suffix(rawvalues(pos))
      n <- length(spls)
      datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) {
        splvals[n]
      } else {
        NA_character_
      }
      argpos <- match(datcol[i], spl_payload(spls[[n]]))
      ## single bracket here because assigning NULL into a list removes
      ## the position entirely
      exargs[i] <- if (argpos <= length(splextra)) {
        splextra[argpos]
      } else {
        list(NULL)
      }
    }
    ## })
    if (all(is.na(datcol))) {
      datcol <- list(NULL)
    } else if (any(is.na(datcol))) {
      stop("mix of var and non-var columns with NA analysis rowvara")
    }
  } else {
    exargs <- splextra
    if (is.null(datcol)) {
      datcol <- list(NULL)
    }
    datcol <- rep(datcol, length(colexprs))
    ## if(gotflist)
    ##     length(exargs) <- length(func) ## func is a list
    exargs <- rep(exargs, length.out = length(colexprs))
  }
  allfuncs <- rep(func, length.out = length(colexprs))

  if (is.null(takesdf)) {
    takesdf <- .takes_df(allfuncs)
  }

  rawvals <- mapply(gen_onerv,
    csub = colexprs,
    col = datcol,
    count = colcounts,
    cextr = colextras,
    cpath = cpaths,
    baselinedf = baselines,
    alt_dfpart = list(alt_dfpart),
    func = allfuncs,
    takesdf = takesdf,
    col_parent_inds = spl_context[, names(colexprs),
      drop = FALSE
    ],
    all_col_exprs = list(colexprs),
    all_col_counts = list(colcounts),
    splextra = exargs,
    MoreArgs = list(
      dfpart = dfpart,
      totcount = totcount,
      inclNAs = inclNAs,
      spl_context = spl_context
    ),
    SIMPLIFY = FALSE
  )

  names(rawvals) <- names(colexprs)
  rawvals
}

.strip_lst_rvals <- function(lst) {
  lapply(lst, rawvalues)
}

#' @noRd
#' @return A list of table rows, even when only one is generated.
.make_tablerows <- function(dfpart,
                            alt_dfpart,
                            func,
                            cinfo,
                            datcol = NULL,
                            lev = 1L,
                            rvlab = NA_character_,
                            format = NULL,
                            defrowlabs = NULL,
                            rowconstr = DataRow,
                            splextra = list(),
                            takesdf = NULL,
                            baselines = replicate(
                              length(col_exprs(cinfo)),
                              list(dfpart[0, ])
                            ),
                            inclNAs,
                            spl_context = context_df_row(cinfo = cinfo)) {
  if (is.null(datcol) && !is.na(rvlab)) {
    stop("NULL datcol but non-na rowvar label")
  }
  if (!is.null(datcol) && !is.na(datcol)) {
    if (!all(datcol %in% names(dfpart))) {
      stop(
        "specified analysis variable (", datcol,
        ") not present in data"
      )
    }

    rowvar <- datcol
  } else {
    rowvar <- NA_character_
  }

  rawvals <- gen_rowvalues(dfpart,
    alt_dfpart = alt_dfpart,
    datcol = datcol,
    cinfo = cinfo,
    func = func,
    splextra = splextra,
    takesdf = takesdf,
    baselines = baselines,
    inclNAs = inclNAs,
    spl_context = spl_context
  )

  ## if(is.null(rvtypes))
  ##     rvtypes = rep(NA_character_, length(rawvals))
  lens <- vapply(rawvals, length, NA_integer_)
  unqlens <- unique(lens)
  ## length 0 returns are ok to not match cause they are
  ## just empty space we can fill in as needed.
  if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 &&
    ## (0 %in% unqlens && length(unqlens) != 2)) {
    stop(
      "Number of rows generated by analysis function do not match ",
      "across all columns. ",
      if (!is.na(datcol) && is.character(dfpart[[datcol]])) {
        paste(
          "\nPerhaps convert analysis variable", datcol,
          "to a factor?"
        )
      }
    )
  }
  maxind <- match(max(unqlens), lens)

  ## look if we got labels, if not apply the
  ## default row labels
  ## this is guaranteed to be a RowsVerticalSection object.
  rv1col <- rawvals[[maxind]]
  ## nocov start
  if (!is(rv1col, "RowsVerticalSection")) {
    stop(
      "gen_rowvalues appears to have generated something that was not ",
      "a RowsVerticalSection object. Please contact the maintainer."
    )
  }
  # nocov end

  labels <- value_labels(rv1col)

  ncrows <- max(unqlens)
  if (ncrows == 0) {
    return(list())
  }
  stopifnot(ncrows > 0)

  if (is.null(labels)) {
    if (length(rawvals[[maxind]]) == length(defrowlabs)) {
      labels <- defrowlabs
    } else {
      labels <- rep("", ncrows)
    }
  }

  rfootnotes <- rep(list(list(), length(rv1col)))
  nms <- value_names(rv1col)
  rfootnotes <- row_footnotes(rv1col)

  imods <- indent_mod(rv1col) ## rv1col@indent_mods
  unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE)

  formatvec <- NULL
  if (!is.null(format)) {
    if (is.function(format)) {
      format <- list(format)
    }
    formatvec <- rep(format, length.out = ncrows)
  }

  trows <- lapply(1:ncrows, function(i) {
    rowvals <- lapply(unwrapped_vals, function(colvals) {
      colvals[[i]]
    })
    imod <- unique(vapply(rowvals, indent_mod, 0L))
    if (length(imod) != 1) {
      stop(
        "Different cells in the same row appear to have been given ",
        "different indent_mod values"
      )
    }
    rowconstr(
      vals = rowvals,
      cinfo = cinfo,
      lev = lev,
      label = labels[i],
      name = nms[i], ## labels[i], ## XXX this is probably wrong?!
      var = rowvar,
      format = formatvec[[i]],
      indent_mod = imods[[i]] %||% 0L,
      footnotes = rfootnotes[[i]] ## one bracket so list
    )
  })
  trows
}

.make_caller <- function(parent_cfun, clabelstr = "") {
  formalnms <- names(formals(parent_cfun))
  ## note the <- here
  if (!is.na(dotspos <- match("...", formalnms))) {
    toremove <- dotspos
  } else {
    toremove <- NULL
  }

  labelstrpos <- match("labelstr", names(formals(parent_cfun)))
  if (is.na(labelstrpos)) {
    stop(
      "content function does not appear to accept the labelstr",
      "arguent"
    )
  }
  toremove <- c(toremove, labelstrpos)
  formalnms <- formalnms[-1 * toremove]

  caller <- eval(parser_helper(text = paste(
    "function() { parent_cfun(",
    paste(formalnms, "=",
      formalnms,
      collapse = ", "
    ),
    ", labelstr = clabelstr, ...)}"
  )))
  formals(caller) <- c(
    formals(parent_cfun)[-labelstrpos],
    alist("..." = )
  ) # nolint
  caller
}

# Makes content table xxx renaming
.make_ctab <- function(df,
                       lvl, ## treepos,
                       name,
                       label,
                       cinfo,
                       parent_cfun = NULL,
                       format = NULL,
                       na_str = NA_character_,
                       indent_mod = 0L,
                       cvar = NULL,
                       inclNAs,
                       alt_df,
                       extra_args,
                       spl_context = context_df_row(cinfo = cinfo)) {
  if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) {
    cvar <- NULL
  }
  if (!is.null(parent_cfun)) {
    ## cfunc <- .make_caller(parent_cfun, label)
    cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label)
    contkids <- tryCatch(
      .make_tablerows(df,
        lev = lvl,
        func = cfunc,
        cinfo = cinfo,
        rowconstr = ContentRow,
        datcol = cvar,
        takesdf = rep(.takes_df(cfunc),
          length.out = ncol(cinfo)
        ),
        inclNAs = FALSE,
        alt_dfpart = alt_df,
        splextra = extra_args,
        spl_context = spl_context
      ),
      error = function(e) e
    )
    if (is(contkids, "error")) {
      stop("Error in content (summary) function: ", contkids$message,
        "\n\toccured at path: ",
        spl_context_to_disp_path(spl_context),
        call. = FALSE
      )
    }
  } else {
    contkids <- list()
  }
  ctab <- ElementaryTable(
    kids = contkids,
    name = paste0(name, "@content"),
    lev = lvl,
    labelrow = LabelRow(),
    cinfo = cinfo,
    iscontent = TRUE,
    format = format,
    indent_mod = indent_mod,
    na_str = na_str
  )
  ctab
}

.make_analyzed_tab <- function(df,
                               alt_df,
                               spl,
                               cinfo,
                               partlabel = "",
                               dolab = TRUE,
                               lvl,
                               baselines,
                               spl_context) {
  stopifnot(is(spl, "VAnalyzeSplit"))
  check_validsplit(spl, df)
  defrlabel <- spl@default_rowlabel
  if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) {
    defrlabel <- partlabel
  }
  kids <- tryCatch(
    .make_tablerows(df,
      func = analysis_fun(spl),
      defrowlabs = defrlabel, # XXX
      cinfo = cinfo,
      datcol = spl_payload(spl),
      lev = lvl + 1L,
      format = obj_format(spl),
      splextra = split_exargs(spl),
      baselines = baselines,
      alt_dfpart = alt_df,
      inclNAs = avar_inclNAs(spl),
      spl_context = spl_context
    ),
    error = function(e) e
  )

  # Adding section_div for DataRows (analyze leaves)
  kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow")

  if (is(kids, "error")) {
    stop("Error applying analysis function (var - ",
      spl_payload(spl) %||% "colvars", "): ", kids$message,
      "\n\toccured at (row) path: ",
      spl_context_to_disp_path(spl_context),
      call. = FALSE
    )
  }
  lab <- obj_label(spl)
  ret <- TableTree(
    kids = kids,
    name = obj_name(spl),
    label = lab,
    lev = lvl,
    cinfo = cinfo,
    format = obj_format(spl),
    na_str = obj_na_str(spl),
    indent_mod = indent_mod(spl)
  )

  labelrow_visible(ret) <- dolab
  ret
}

#' @param ... all arguments to `recurse_applysplit`, methods may only use some of them.
#' @return A `list` of children to place at this level.
#'
#' @noRd
setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) {
  standardGeneric(".make_split_kids")
})

## single AnalyzeSplit
setMethod(
  ".make_split_kids", "VAnalyzeSplit",
  function(spl,
           have_controws, ## unused here
           make_lrow, ## unused here
           ...,
           df,
           alt_df,
           lvl,
           name,
           cinfo,
           baselines,
           spl_context,
           nsibs = 0) {
    spvis <- labelrow_visible(spl)
    if (is.na(spvis)) {
      spvis <- nsibs > 0
    }

    ret <- .make_analyzed_tab(
      df = df,
      alt_df,
      spl = spl,
      cinfo = cinfo,
      lvl = lvl + 1L,
      dolab = spvis,
      partlabel = obj_label(spl),
      baselines = baselines,
      spl_context = spl_context
    )
    indent_mod(ret) <- indent_mod(spl)

    kids <- list(ret)
    names(kids) <- obj_name(ret)
    kids
  }
)

# Adding section_divisors to TableRow
.set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") {
  if (!is.na(trailing_section_div_char)) {
    lst <- lapply(
      lst,
      function(k) {
        if (is(k, allowed_class)) {
          trailing_section_div(k) <- trailing_section_div_char
        }
        k
      }
    )
  }
  lst
}

## 1 or more AnalyzeSplits
setMethod(
  ".make_split_kids", "AnalyzeMultiVars",
  function(spl,
           have_controws,
           make_lrow, ## used here
           spl_context,
           ...) { ## all passed directly down to VAnalyzeSplit method
    avspls <- spl_payload(spl)

    nspl <- length(avspls)

    kids <- unlist(lapply(avspls,
      .make_split_kids,
      nsibs = nspl - 1,
      have_controws = have_controws,
      make_lrow = make_lrow,
      spl_context = spl_context,
      ...
    ))

    kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree")

    ## XXX this seems like it should be identical not !identical
    ## TODO FIXME
    if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) {
      ## we only analyzed one var so
      ## we don't need an extra wrapper table
      ## in the structure
      stopifnot(identical(
        obj_name(kids[[1]]),
        spl_payload(spl)
      ))
      return(kids[[1]])
    }
    ## this will be the variables
    ## nms = sapply(spl_payload(spl), spl_payload)

    nms <- vapply(kids, obj_name, "")
    labs <- vapply(kids, obj_label, "")
    if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) {
      warning("Non-unique sibling analysis table names. Using Labels ",
        "instead. Use the table_names argument to analyze to avoid ",
        "this when analyzing the same variable multiple times.",
        "\n\toccured at (row) path: ",
        spl_context_to_disp_path(spl_context),
        call. = FALSE
      )
      kids <- mapply(function(k, nm) {
        obj_name(k) <- nm
        k
      }, k = kids, nm = labs, SIMPLIFY = FALSE)
      nms <- labs
    }

    nms[is.na(nms)] <- ""

    names(kids) <- nms
    kids
  }
)

setMethod(
  ".make_split_kids", "Split",
  function(spl,
           have_controws,
           make_lrow,
           ...,
           splvec, ## passed to recursive_applysplit
           df, ## used to apply split
           alt_df, ## used to apply split for alternative df
           lvl, ## used to calculate innerlev
           cinfo, ## used for sanity check
           baselines, ## used to calc new baselines
           spl_context) {
    ## do the core splitting of data into children for this split
    rawpart <- do_split(spl, df, spl_context = spl_context)
    dataspl <- rawpart[["datasplit"]]
    ## these are SplitValue objects
    splvals <- rawpart[["values"]]
    partlabels <- rawpart[["labels"]]
    if (is.factor(partlabels)) {
      partlabels <- as.character(partlabels)
    }
    nms <- unlist(value_names(splvals))
    if (is.factor(nms)) {
      nms <- as.character(nms)
    }

    ## Get new baseline values
    ##
    ## XXX this is a lot of data churn, if it proves too slow
    ## we can
    ## a) check if any of the analyses (i.e. the afuns) need the baseline in this
    ##    splitvec and not do any of this if not, or
    ## b) refactor row splitting to behave like column splitting
    ##
    ## (b) seems the better design but is a major reworking of the guts of how
    ## rtables tabulation works
    ## (a) will only help if analyses that use baseline
    ## info are mixed with those who don't.
    newbl_raw <- lapply(baselines, function(dat) {
      # If no ref_group is specified
      if (is.null(dat)) {
        return(NULL)
      }

      ## apply the same splitting on the
      bldataspl <- tryCatch(do_split(spl, dat, spl_context = spl_context)[["datasplit"]],
        error = function(e) e
      )

      # Error localization
      if (is(bldataspl, "error")) {
        stop("Following error encountered in splitting .ref_group (baselines): ",
          bldataspl$message,
          call. = FALSE
        )
      }

      ## we only keep the ones corresponding with actual data splits
      res <- lapply(
        names(dataspl),
        function(nm) {
          if (nm %in% names(bldataspl)) {
            bldataspl[[nm]]
          } else {
            dataspl[[1]][0, ]
          }
        }
      )

      names(res) <- names(dataspl)
      res
    })

    newbaselines <- lapply(names(dataspl), function(nm) {
      lapply(newbl_raw, function(rawdat) {
        if (nm %in% names(rawdat)) {
          rawdat[[nm]]
        } else {
          rawdat[[1]][0, ]
        }
      })
    })

    if (length(newbaselines) != length(dataspl)) {
      stop(
        "Baselines (ref_group) after row split does not have",
        " the same number of levels of input data split. ",
        "Contact the maintainer."
      ) # nocov
    }
    if (!(length(newbaselines) == 0 ||
      identical(
        unique(sapply(newbaselines, length)),
        length(col_exprs(cinfo))
      ))) {
      stop(
        "Baselines (ref_group) do not have the same number of columns",
        " in each split. Contact the maintainer."
      ) # nocov
    }

    # If params are not present do not do the calculation
    acdf_param <- check_afun_cfun_params(
      SplitVector(spl, splvec),
      c(".alt_df", ".alt_df_row")
    )

    # Apply same split for alt_counts_df
    if (!is.null(alt_df) && any(acdf_param)) {
      alt_dfpart <- tryCatch(
        do_split(spl, alt_df,
          spl_context = spl_context
        )[["datasplit"]],
        error = function(e) e
      )

      # Removing NA rows - to explore why this happens at all in a split
      # This would be a fix but it is done in post-processing instead of pre-proc -> xxx
      # x alt_dfpart <- lapply(alt_dfpart, function(data) {
      # x    data[!apply(is.na(data), 1, all), ]
      # x })

      # Error localization
      if (is(alt_dfpart, "error")) {
        stop("Following error encountered in splitting alt_counts_df: ",
          alt_dfpart$message,
          call. = FALSE
        )
      }
      # Error if split does not have the same values in the alt_df (and order)
      # The following breaks if there are different levels (do_split returns empty list)
      # or if there are different number of the same levels. Added handling of NAs
      # in the values of the factor when is all only NAs
      is_all_na <- all(is.na(alt_df[[spl_payload(spl)]]))

      if (!all(names(dataspl) %in% names(alt_dfpart)) || length(alt_dfpart) != length(dataspl) || is_all_na) {
        alt_df_spl_vals <- unique(alt_df[[spl_payload(spl)]])
        end_part <- ""

        if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) {
          end_part <- paste0(
            " and following levels: ",
            paste_vec(levels(alt_df_spl_vals))
          )
        }

        if (is_all_na) {
          end_part <- ". Found only NAs in alt_counts_df split"
        }

        stop(
          "alt_counts_df split variable(s) [", spl_payload(spl),
          "] (in split ", as.character(class(spl)),
          ") does not have the same factor levels of df.\ndf has c(", '"',
          paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ",
          ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""),
          " unique values", end_part
        )
      }
    } else {
      alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl))
    }


    innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow)
    ## do full recursive_applysplit on each part of the split defined by spl
    inner <- unlist(mapply(
      function(dfpart, alt_dfpart, nm, label, baselines, splval) {
        rsplval <- context_df_row(
          split = obj_name(spl),
          value = value_names(splval),
          full_parent_df = list(dfpart),
          cinfo = cinfo
        )

        ## if(length(rsplval) > 0)
        ##     rsplval <- setNames(rsplval, obj_name(spl))
        recursive_applysplit(
          df = dfpart,
          alt_df = alt_dfpart,
          name = nm,
          lvl = innerlev,
          splvec = splvec,
          cinfo = cinfo,
          make_lrow = label_kids(spl),
          parent_cfun = content_fun(spl),
          cformat = content_format(spl),
          cna_str = content_na_str(spl),
          partlabel = label,
          cindent_mod = content_indent_mod(spl),
          cvar = content_var(spl),
          baselines = baselines,
          cextra_args = content_extra_args(spl),
          ## splval should still be retaining its name
          spl_context = rbind(spl_context, rsplval)
        )
      },
      dfpart = dataspl,
      alt_dfpart = alt_dfpart,
      label = partlabels,
      nm = nms,
      baselines = newbaselines,
      splval = splvals,
      SIMPLIFY = FALSE
    ))

    # Setting the kids section separator if they inherits VTableTree
    inner <- .set_kids_section_div(
      inner,
      trailing_section_div_char = spl_section_div(spl),
      allowed_class = "VTableTree"
    )

    ## This is where we need to build the structural tables
    ## even if they are invisible because their labels are not
    ## not shown.
    innertab <- TableTree(
      kids = inner,
      name = obj_name(spl),
      labelrow = LabelRow(
        label = obj_label(spl),
        vis = isTRUE(vis_label(spl))
      ),
      cinfo = cinfo,
      iscontent = FALSE,
      indent_mod = indent_mod(spl),
      page_title = ptitle_prefix(spl)
    )
    ## kids = inner
    kids <- list(innertab)
    kids
  }
)

context_df_row <- function(split = character(),
                           value = character(),
                           full_parent_df = list(),
                           cinfo = NULL) {
  ret <- data.frame(
    split = split,
    value = value,
    full_parent_df = I(full_parent_df),
    #     parent_cold_inds = I(parent_col_inds),
    stringsAsFactors = FALSE
  )
  if (nrow(ret) > 0) {
    ret$all_cols_n <- nrow(full_parent_df[[1]])
  } else {
    ret$all_cols_n <- integer() ## should this be numeric??? This never happens
  }

  if (!is.null(cinfo)) {
    if (nrow(ret) > 0) {
      colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) {
        vals <- eval(e, envir = full_parent_df[[1]])
        if (identical(vals, TRUE)) {
          vals <- rep(vals, length.out = nrow(full_parent_df[[1]]))
        }
        I(list(vals))
      }))
    } else {
      colcols <- as.data.frame(rep(list(logical()), ncol(cinfo)))
    }
    names(colcols) <- names(col_exprs(cinfo))
    ret <- cbind(ret, colcols)
  }
  ret
}

recursive_applysplit <- function(df,
                                 lvl = 0L,
                                 alt_df,
                                 splvec,
                                 name,
                                 #         label,
                                 make_lrow = NA,
                                 partlabel = "",
                                 cinfo,
                                 parent_cfun = NULL,
                                 cformat = NULL,
                                 cna_str = NA_character_,
                                 cindent_mod = 0L,
                                 cextra_args = list(),
                                 cvar = NULL,
                                 baselines = lapply(
                                   col_extra_args(cinfo),
                                   function(x) x$.ref_full
                                 ),
                                 spl_context = context_df_row(cinfo = cinfo),
                                 no_outer_tbl = FALSE,
                                 parent_sect_split = NA_character_) {
  ## pre-existing table was added to the layout
  if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) {
    return(splvec[[1]])
  }

  ## the content function is the one from the PREVIOUS
  ## split, i.e. the one whose children we are now constructing
  ## this is a bit annoying but makes the semantics for
  ## declaring layouts much more sane.
  ctab <- .make_ctab(df,
    lvl = lvl,
    name = name,
    label = partlabel,
    cinfo = cinfo,
    parent_cfun = parent_cfun,
    format = cformat,
    na_str = cna_str,
    indent_mod = cindent_mod,
    cvar = cvar,
    alt_df = alt_df,
    extra_args = cextra_args,
    spl_context = spl_context
  )

  nonroot <- lvl != 0L

  if (is.na(make_lrow)) {
    make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE
  }
  ## never print an empty row label for root.
  if (make_lrow && partlabel == "" && !nonroot) {
    make_lrow <- FALSE
  }

  if (length(splvec) == 0L) {
    kids <- list()
    imod <- 0L
    spl <- NULL
  } else {
    spl <- splvec[[1]]
    splvec <- splvec[-1]

    ## we pass this everything recursive_applysplit received and
    ## it all gets passed around through ... as needed
    ## to the various methods of .make_split_kids
    kids <- .make_split_kids(
      spl = spl,
      df = df,
      alt_df = alt_df,
      lvl = lvl,
      splvec = splvec,
      name = name,
      make_lrow = make_lrow,
      partlabel = partlabel,
      cinfo = cinfo,
      parent_cfun = parent_cfun,
      cformat = cformat,
      cindent_mod = cindent_mod,
      cextra_args = cextra_args, cvar = cvar,
      baselines = baselines,
      spl_context = spl_context,
      have_controws = nrow(ctab) > 0
    )
    imod <- 0L
  } ## end length(splvec)

  if (is.na(make_lrow)) {
    make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE
  }
  ## never print an empty row label for root.
  if (make_lrow && partlabel == "" && !nonroot) {
    make_lrow <- FALSE
  }

  ## this is only true when called from build_table and the first split
  ## in (one of the) SplitVector is NOT an AnalyzeMultiVars split.
  ## in that case we would be "double creating" the structural
  ## subtable
  if (no_outer_tbl) {
    ret <- kids[[1]]
    indent_mod(ret) <- indent_mod(spl)
  } else if (nrow(ctab) > 0L || length(kids) > 0L) {
    ## previously we checked if the child had an identical label
    ## but I don't think thats needed anymore.
    tlabel <- partlabel
    ret <- TableTree(
      cont = ctab,
      kids = kids,
      name = name,
      label = tlabel, # partlabel,
      lev = lvl,
      iscontent = FALSE,
      labelrow = LabelRow(
        lev = lvl,
        label = tlabel,
        cinfo = cinfo,
        vis = make_lrow
      ),
      cinfo = cinfo,
      indent_mod = imod
    )
  } else {
    ret <- NULL
  }

  ## if(!is.null(spl) && !is.na(spl_section_sep(spl)))
  ##     ret <- apply_kids_section_sep(ret, spl_section_sep(spl))
  ## ## message(sprintf("indent modifier: %d", indentmod))
  ## if(!is.null(ret))
  ##     indent_mod(ret) = indentmod
  ret
}

#' Create a table from a layout and data
#'
#' Layouts are used to describe a table pre-data. `build_table` is used to create a table
#' using a layout and a dataset.
#'
#' @inheritParams gen_args
#' @inheritParams lyt_args
#' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts
#'   *for leaf-columns only* which override those calculated automatically during tabulation. Must specify
#'   "counts" for *all* leaf-columns if non-`NULL`. `NA` elements will be replaced with the automatically
#'   calculated counts. Turns on display of leaf-column counts when non-`NULL`.
#' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`.
#' @param ... ignored.
#'
#' @details
#' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting
#' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and
#' counting the observations in each resulting subset.
#'
#' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have
#' been calculated based on `df` and simply re-used for the count calculation.
#'
#' @note
#' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called
#' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation
#' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the
#' only way to ensure overridden counts are fully respected.
#'
#' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations
#'   declared in `lyt` to the data `df`.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze("Sepal.Length", afun = function(x) {
#'     list(
#'       "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "range" = diff(range(x))
#'     )
#'   })
#' lyt
#'
#' tbl <- build_table(lyt, iris)
#' tbl
#'
#' # analyze multiple variables
#' lyt2 <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) {
#'     list(
#'       "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "range" = diff(range(x))
#'     )
#'   })
#'
#' tbl2 <- build_table(lyt2, iris)
#' tbl2
#'
#' # an example more relevant for clinical trials with column counts
#' lyt3 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = function(x) {
#'     setNames(as.list(fivenum(x)), c(
#'       "minimum", "lower-hinge", "median",
#'       "upper-hinge", "maximum"
#'     ))
#'   })
#'
#' tbl3 <- build_table(lyt3, DM)
#' tbl3
#'
#' tbl4 <- build_table(lyt3, subset(DM, AGE > 40))
#' tbl4
#'
#' # with column counts calculated based on different data
#' miniDM <- DM[sample(1:NROW(DM), 100), ]
#' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM)
#' tbl5
#'
#' tbl6 <- build_table(lyt3, DM, col_counts = 1:3)
#' tbl6
#'
#' @author Gabriel Becker
#' @export
build_table <- function(lyt, df,
                        alt_counts_df = NULL,
                        col_counts = NULL,
                        col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df),
                        topleft = NULL,
                        hsep = default_hsep(),
                        ...) {
  if (!is(lyt, "PreDataTableLayouts")) {
    stop(
      "lyt must be a PreDataTableLayouts object. Got object of class ",
      class(lyt)
    )
  }

  ## if no columns are defined (e.g. because lyt is NULL)
  ## add a single overall column as the "most basic"
  ## table column structure that makes sense
  clyt <- clayout(lyt)
  if (length(clyt) == 1 && length(clyt[[1]]) == 0) {
    clyt[[1]] <- add_overall_col(clyt[[1]], "")
    clayout(lyt) <- clyt
  }

  ## do checks and defensive programming now that we have the data
  lyt <- fix_dyncuts(lyt, df)
  lyt <- set_def_child_ord(lyt, df)
  lyt <- fix_analyze_vis(lyt)
  df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts))
  alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row"))
  if (any(alt_params) && is.null(alt_counts_df)) {
    stop(
      "Layout contains afun/cfun functions that have optional parameters ",
      ".alt_df and/or .alt_df_row, but no alt_counts_df was provided in ",
      "build_table()."
    )
  }

  rtpos <- TreePos()
  cinfo <- create_colinfo(lyt, df, rtpos,
    counts = col_counts,
    alt_counts_df = alt_counts_df,
    total = col_total,
    topleft
  )
  if (!is.null(col_counts)) {
    toreplace <- !is.na(col_counts)
    newccs <- col_counts(cinfo) ## old actual counts
    newccs[toreplace] <- col_counts[toreplace]
    col_counts(cinfo) <- newccs
    leaf_paths <- col_paths(cinfo)
    for (pth in leaf_paths) {
      colcount_visible(cinfo, pth) <- TRUE
    }
  }
  rlyt <- rlayout(lyt)
  rtspl <- root_spl(rlyt)
  ctab <- .make_ctab(df, 0L,
    alt_df = NULL,
    name = "root",
    label = "",
    cinfo = cinfo, ## cexprs, ctree,
    parent_cfun = content_fun(rtspl),
    format = content_format(rtspl),
    na_str = content_na_str(rtspl),
    indent_mod = 0L,
    cvar = content_var(rtspl),
    extra_args = content_extra_args(rtspl)
  )

  kids <- lapply(seq_along(rlyt), function(i) {
    splvec <- rlyt[[i]]
    if (length(splvec) == 0) {
      return(NULL)
    }
    firstspl <- splvec[[1]]
    nm <- obj_name(firstspl)
    ## XXX unused, probably shouldn't be?
    ## this seems to be covered by grabbing the partlabel
    ## TODO confirm this
    ## lab <- obj_label(firstspl)
    recursive_applysplit(
      df = df, lvl = 0L,
      alt_df = alt_counts_df,
      name = nm,
      splvec = splvec,
      cinfo = cinfo,
      ## XXX are these ALWAYS right?
      make_lrow = label_kids(firstspl),
      parent_cfun = NULL,
      cformat = content_format(firstspl),
      cna_str = content_na_str(firstspl),
      cvar = content_var(firstspl),
      cextra_args = content_extra_args(firstspl),
      spl_context = context_df_row(
        split = "root", value = "root",
        full_parent_df = list(df),
        cinfo = cinfo
      ),
      ## we DO want the 'outer table' if the first
      ## one is a multi-analyze
      no_outer_tbl = !is(firstspl, "AnalyzeMultiVars")
    )
  })
  kids <- kids[!sapply(kids, is.null)]
  if (length(kids) > 0) names(kids) <- sapply(kids, obj_name)

  # top level divisor
  if (!is.na(top_level_section_div(lyt))) {
    kids <- lapply(kids, function(first_level_kids) {
      trailing_section_div(first_level_kids) <- top_level_section_div(lyt)
      first_level_kids
    })
  }

  if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) {
    tab <- kids[[1]]
    main_title(tab) <- main_title(lyt)
    subtitles(tab) <- subtitles(lyt)
    main_footer(tab) <- main_footer(lyt)
    prov_footer(tab) <- prov_footer(lyt)
    header_section_div(tab) <- header_section_div(lyt)
  } else {
    tab <- TableTree(
      cont = ctab,
      kids = kids,
      lev = 0L,
      name = "root",
      label = "",
      iscontent = FALSE,
      cinfo = cinfo,
      format = obj_format(rtspl),
      na_str = obj_na_str(rtspl),
      title = main_title(lyt),
      subtitles = subtitles(lyt),
      main_footer = main_footer(lyt),
      prov_footer = prov_footer(lyt),
      header_section_div = header_section_div(lyt)
    )
  }

  ## This seems to be unneeded, not clear what 'top_left' check it refers to
  ## but both top_left taller than column headers and very long topleft are now
  ## allowed, so this is just wasted computation.

  ## ## this is where the top_left check lives right now. refactor later maybe
  ## ## but now just call it so the error gets thrown when I want it to
  ## unused <- matrix_form(tab)
  tab <- update_ref_indexing(tab)
  horizontal_sep(tab) <- hsep
  if (table_inset(lyt) > 0) {
    table_inset(tab) <- table_inset(lyt)
  }
  tab
}

# fix_split_vars ----
# These checks guarantee that all the split variables are present in the data.
# No generic is needed because it is not dependent on the input layout but
# on the df.
fix_one_split_var <- function(spl, df, char_ok = TRUE) {
  var <- spl_payload(spl)
  if (!(var %in% names(df))) {
    stop("Split variable [", var, "] not found in data being tabulated.")
  }
  varvec <- df[[var]]
  if (!is(varvec, "character") && !is.factor(varvec)) {
    message(sprintf(
      paste(
        "Split var [%s] was not character or factor.",
        "Converting to factor"
      ),
      var
    ))
    varvec <- factor(varvec)
    df[[var]] <- varvec
  } else if (is(varvec, "character") && !char_ok) {
    stop(
      "Overriding column counts is not supported when splitting on ",
      "character variables.\n Please convert all column split variables to ",
      "factors."
    )
  }

  if (is.factor(varvec)) {
    levs <- levels(varvec)
  } else {
    levs <- unique(varvec)
  }
  if (!all(nzchar(levs))) {
    stop(
      "Got empty string level in splitting variable ", var,
      " This is not supported.\nIf display as an empty level is ",
      "desired use a value-labeling variable."
    )
  }

  ## handle label var
  lblvar <- spl_label_var(spl)
  have_lblvar <- !identical(var, lblvar)
  if (have_lblvar) {
    if (!(lblvar %in% names(df))) {
      stop(
        "Value label variable [", lblvar,
        "] not found in data being tabulated."
      )
    }
    lblvec <- df[[lblvar]]
    tab <- table(varvec, lblvec)

    if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) {
      stop(sprintf(
        paste(
          "There does not appear to be a 1-1",
          "correspondence between values in split var",
          "[%s] and label var [%s]"
        ),
        var, lblvar
      ))
    }

    if (!is(lblvec, "character") && !is.factor(lblvec)) {
      message(sprintf(
        paste(
          "Split label var [%s] was not character or",
          "factor. Converting to factor"
        ),
        var
      ))
      lblvec <- factor(lblvec)
      df[[lblvar]] <- lblvec
    }
  }

  df
}

fix_split_vars <- function(lyt, df, char_ok) {
  df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok)
  df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE)
  df

  ## clyt <- clayout(lyt)
  ## rlyt <- rlayout(lyt)

  ## allspls <- unlist(list(clyt, rlyt))
  ## VarLevelSplit includes sublclass VarLevWBaselineSplit
}

fix_split_vars_inner <- function(lyt, df, char_ok) {
  stopifnot(is(lyt, "PreDataAxisLayout"))
  allspls <- unlist(lyt)
  varspls <- allspls[sapply(allspls, is, "VarLevelSplit")]
  unqvarinds <- !duplicated(sapply(varspls, spl_payload))
  unqvarspls <- varspls[unqvarinds]
  for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok)

  df
}

# set_def_child_ord ----
## the table is built by recursively splitting the data and doing things to each
## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to
## be the same in all the different partitions. This addresses that.
setGeneric(
  "set_def_child_ord",
  function(lyt, df) standardGeneric("set_def_child_ord")
)

setMethod(
  "set_def_child_ord", "PreDataTableLayouts",
  function(lyt, df) {
    clayout(lyt) <- set_def_child_ord(clayout(lyt), df)
    rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df)
    lyt
  }
)

setMethod(
  "set_def_child_ord", "PreDataAxisLayout",
  function(lyt, df) {
    lyt@.Data <- lapply(lyt, set_def_child_ord, df = df)
    lyt
  }
)

setMethod(
  "set_def_child_ord", "SplitVector",
  function(lyt, df) {
    lyt[] <- lapply(lyt, set_def_child_ord, df = df)
    lyt
  }
)

## for most split types, don't do anything
## becuause their ordering already isn't data-based
setMethod(
  "set_def_child_ord", "ANY",
  function(lyt, df) lyt
)

setMethod(
  "set_def_child_ord", "VarLevelSplit",
  function(lyt, df) {
    if (!is.null(spl_child_order(lyt))) {
      return(lyt)
    }

    vec <- df[[spl_payload(lyt)]]
    vals <- if (is.factor(vec)) {
      levels(vec)
    } else {
      unique(vec)
    }
    spl_child_order(lyt) <- vals
    lyt
  }
)

setMethod(
  "set_def_child_ord", "VarLevWBaselineSplit",
  function(lyt, df) {
    bline <- spl_ref_group(lyt)
    if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) {
      return(lyt)
    }

    if (!is.null(split_fun(lyt))) {
      ## expensive but sadly necessary, I think
      pinfo <- do_split(lyt, df, spl_context = context_df_row())
      vals <- sort(unlist(value_names(pinfo$values)))
    } else {
      vec <- df[[spl_payload(lyt)]]
      vals <- if (is.factor(vec)) {
        levels(vec)
      } else {
        unique(vec)
      }
    }
    if (!bline %in% vals) {
      stop(paste0(
        'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data."
      ))
    }
    spl_child_order(lyt) <- vals
    lyt
  }
)

splitvec_to_coltree <- function(df, splvec, pos = NULL,
                                lvl = 1L, label = "",
                                spl_context = context_df_row(cinfo = NULL),
                                alt_counts_df = df,
                                global_cc_format) {
  stopifnot(
    lvl <= length(splvec) + 1L,
    is(splvec, "SplitVector")
  )


  if (lvl == length(splvec) + 1L) {
    ## XXX this should be a LayoutColree I Think.
    nm <- unlist(tail(value_names(pos), 1)) %||% ""
    spl <- tail(pos_splits(pos), 1)[[1]]
    fmt <- colcount_format(spl) %||% global_cc_format
    LayoutColLeaf(
      lev = lvl - 1L,
      label = label,
      tpos = pos,
      name = nm,
      colcount = NROW(alt_counts_df),
      disp_ccounts = disp_ccounts(spl),
      colcount_format = fmt
    )
  } else {
    spl <- splvec[[lvl]]
    nm <- if (is.null(pos) || length(pos_splits(pos)) == 0) {
      obj_name(spl)
    } else {
      unlist(tail(
        value_names(pos),
        1
      ))
    }
    rawpart <- do_split(spl, df,
      trim = FALSE,
      spl_context = spl_context
    )
    datparts <- rawpart[["datasplit"]]
    vals <- rawpart[["values"]]
    labs <- rawpart[["labels"]]

    force(alt_counts_df)
    kids <- mapply(
      function(dfpart, value, partlab) {
        ## we could pass subset expression in here but the spec
        ## currently doesn't call for it in column space
        newprev <- context_df_row(
          split = obj_name(spl),
          value = value_names(value),
          full_parent_df = list(dfpart),
          cinfo = NULL
        )
        ## subset expressions handled inside make_child_pos,
        ## value is (optionally, for the moment) carrying it around
        newpos <- make_child_pos(pos, spl, value, partlab)
        acdf_subset_expr <- make_subset_expr(spl, value)
        new_acdf_subset <- try(eval(acdf_subset_expr, alt_counts_df), silent = TRUE)
        if (is(new_acdf_subset, "try-error")) {
          stop(sprintf(
            paste(
              ifelse(identical(df, alt_counts_df), "df", "alt_counts_df"),
              "appears incompatible with column-split",
              "structure. Offending column subset",
              "expression: %s\nOriginal error",
              "message: %s"
            ), deparse(acdf_subset_expr[[1]]),
            conditionMessage(attr(new_acdf_subset, "condition"))
          ))
        }

        splitvec_to_coltree(dfpart, splvec, newpos,
          lvl + 1L, partlab,
          spl_context = rbind(spl_context, newprev),
          alt_counts_df = alt_counts_df[new_acdf_subset, , drop = FALSE],
          global_cc_format = global_cc_format
        )
      },
      dfpart = datparts, value = vals,
      partlab = labs, SIMPLIFY = FALSE
    )
    disp_cc <- FALSE
    cc_format <- global_cc_format # this doesn't matter probably, but its technically more correct
    if (lvl > 1) {
      disp_cc <- disp_ccounts(splvec[[lvl - 1]])
      cc_format <- colcount_format(splvec[[lvl - 1]]) %||% global_cc_format
    }

    names(kids) <- value_names(vals)
    LayoutColTree(
      lev = lvl, label = label,
      spl = spl,
      kids = kids, tpos = pos,
      name = nm,
      summary_function = content_fun(spl),
      colcount = NROW(alt_counts_df),
      disp_ccounts = disp_cc,
      colcount_format = cc_format
    )
  }
}

# fix_analyze_vis ----
## now that we know for sure the number of siblings
## collaplse NAs to TRUE/FALSE for whether
## labelrows should be visible for ElementaryTables
## generatead from analyzing a single variable
setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis"))

setMethod(
  "fix_analyze_vis", "PreDataTableLayouts",
  function(lyt) {
    rlayout(lyt) <- fix_analyze_vis(rlayout(lyt))
    lyt
  }
)

setMethod(
  "fix_analyze_vis", "PreDataRowLayout",
  function(lyt) {
    splvecs <- lapply(lyt, fix_analyze_vis)
    PreDataRowLayout(
      root = root_spl(lyt),
      lst = splvecs
    )
  }
)

setMethod(
  "fix_analyze_vis", "SplitVector",
  function(lyt) {
    len <- length(lyt)
    if (len == 0) {
      return(lyt)
    }
    lastspl <- lyt[[len]]
    if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) {
      return(lyt)
    }

    if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) {
      ##  labelrow_visible(lastspl) = FALSE
      labelrow_visible(lastspl) <- "hidden"
    } else if (is(lastspl, "AnalyzeMultiVar")) {
      pld <- spl_payload(lastspl)
      newpld <- lapply(pld, function(sp, havesibs) {
        if (is.na(labelrow_visible(sp))) {
          labelrow_visible(sp) <- havesibs
        }
      }, havesibs = len > 1)
      spl_payload(lastspl) <- newpld
      ## pretty sure this isn't needed...
      if (is.na(label_kids(lastspl))) {
        label_kids(lastspl) <- len > 1
      }
    }
    lyt[[len]] <- lastspl
    lyt
  }
)

# check_afun_cfun_params ----

# This checks if the input params are used anywhere in cfun/afun
setGeneric("check_afun_cfun_params", function(lyt, params) {
  standardGeneric("check_afun_cfun_params")
})

setMethod(
  "check_afun_cfun_params", "PreDataTableLayouts",
  function(lyt, params) {
    # clayout does not have analysis functions
    check_afun_cfun_params(rlayout(lyt), params)
  }
)

setMethod(
  "check_afun_cfun_params", "PreDataRowLayout",
  function(lyt, params) {
    ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params)
    r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params)
    Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l))
  }
)

# Main function for checking parameters
setMethod(
  "check_afun_cfun_params", "SplitVector",
  function(lyt, params) {
    param_l <- lapply(lyt, check_afun_cfun_params, params = params)
    Reduce(`|`, param_l)
  }
)

# Helper function for check_afun_cfun_params
.afun_cfun_switch <- function(spl_i) {
  if (is(spl_i, "VAnalyzeSplit")) {
    analysis_fun(spl_i)
  } else {
    content_fun(spl_i)
  }
}

# Extreme case that happens only when using add_existing_table
setMethod(
  "check_afun_cfun_params", "VTableTree",
  function(lyt, params) {
    setNames(logical(length(params)), params) # All FALSE
  }
)

setMethod(
  "check_afun_cfun_params", "Split",
  function(lyt, params) {
    # Extract function in the split
    fnc <- .afun_cfun_switch(lyt)

    # For each parameter, check if it is called
    sapply(params, function(pai) any(unlist(func_takes(fnc, pai))))
  }
)

# Helper functions ----

count <- function(df, ...) NROW(df)

guess_format <- function(val) {
  if (length(val) == 1) {
    if (is.integer(val) || !is.numeric(val)) {
      "xx"
    } else {
      "xx.xx"
    }
  } else if (length(val) == 2) {
    "xx.x / xx.x"
  } else if (length(val) == 3) {
    "xx.x (xx.x - xx.x)"
  } else {
    stop("got value of length > 3")
  }
}

.quick_afun <- function(afun, lbls) {
  if (.takes_df(afun)) {
    function(df, .spl_context, ...) {
      if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
        lbls <- tail(.spl_context$value, 1)
      }
      if (".spl_context" %in% names(formals(afun))) {
        res <- afun(df = df, .spl_context = .spl_context, ...)
      } else {
        res <- afun(df = df, ...)
      }
      if (is(res, "RowsVerticalSection")) {
        ret <- res
      } else {
        if (!is.list(res)) {
          ret <- rcell(res, label = lbls, format = guess_format(res))
        } else {
          if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
            names(res) <- lbls
          }
          ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))
        }
      }
      ret
    }
  } else {
    function(x, .spl_context, ...) {
      if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
        lbls <- tail(.spl_context$value, 1)
      }
      if (".spl_context" %in% names(formals(afun))) {
        res <- afun(x = x, .spl_context = .spl_context, ...)
      } else {
        res <- afun(x = x, ...)
      }
      if (is(res, "RowsVerticalSection")) {
        ret <- res
      } else {
        if (!is.list(res)) {
          ret <- rcell(res, label = lbls, format = guess_format(res))
        } else {
          if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
            names(res) <- lbls
          }
          ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))
        }
      }
      ret
    }
  }
}

# qtable ----

n_cells_res <- function(res) {
  ans <- 1L
  if (is.list(res)) {
    ans <- length(res)
  } else if (is(res, "RowsVerticalSection")) {
    ans <- length(res$values)
  } # XXX penetrating the abstraction
  ans
}

#' Generalized frequency table
#'
#' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and
#' column space can be facetted by variables, and an analysis function can be specified. The function then builds a
#' layout with the specified layout and applies it to the data provided.
#'
#' @inheritParams constr_args
#' @inheritParams basic_table
#' @param row_vars (`character`)\cr the names of variables to be used in row facetting.
#' @param col_vars (`character`)\cr the names of variables to be used in column facetting.
#' @param data (`data.frame`)\cr the data to tabulate.
#' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`.
#' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must
#'   match the number of rows generated by `afun`.
#' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis
#'   function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas
#'   lists are interpreted as multiple cells.
#' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to
#'   `TRUE`.
#' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to
#'   `FALSE`.
#' @param ... additional arguments passed to `afun`.
#' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users.
#'
#' @details
#' This function creates a table with a single top-level structure in both row and column dimensions involving faceting
#' by 0 or more variables in each dimension.
#'
#' The display of the table depends on certain details of the tabulation. In the case of an `afun` which returns a
#' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row
#' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun`
#' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row
#' labels and the deepest-nested facet row labels will be visible.
#'
#' The table will be annotated in the top-left area with an informative label displaying the analysis variable
#' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception
#' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and
#' an `afun` which returns a single row.
#'
#' @return
#' * `qtable` returns a built `TableTree` object representing the desired table
#' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for
#'   passing to [build_table()].
#'
#' @examples
#' qtable(ex_adsl)
#' qtable(ex_adsl, row_vars = "ARM")
#' qtable(ex_adsl, col_vars = "ARM")
#' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM")
#' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
#' qtable(ex_adsl,
#'   row_vars = c("COUNTRY", "SEX"),
#'   col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
#' )
#' summary_list <- function(x, ...) as.list(summary(x))
#' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list)
#' suppressWarnings(qtable(ex_adsl,
#'   row_vars = "SEX",
#'   col_vars = "ARM", avar = "AGE", afun = range
#' ))
#'
#' @export
qtable_layout <- function(data,
                          row_vars = character(),
                          col_vars = character(),
                          avar = NULL,
                          row_labels = NULL,
                          afun = NULL,
                          summarize_groups = FALSE,
                          title = "",
                          subtitles = character(),
                          main_footer = character(),
                          prov_footer = character(),
                          show_colcounts = TRUE,
                          drop_levels = TRUE,
                          ...,
                          .default_rlabel = NULL) {
  subafun <- substitute(afun)
  if (!is.null(.default_rlabel)) {
    dflt_row_lbl <- .default_rlabel
  } else if (
    is.name(subafun) &&
      is.function(afun) &&
      ## this is gross. basically testing
      ## if the symbol we have corresponds
      ## in some meaningful way to the function
      ## we will be calling.
      identical(
        mget(
          as.character(subafun),
          mode = "function",
          envir = parent.frame(1),
          ifnotfound = list(NULL),
          inherits = TRUE
        )[[1]],
        afun
      )
  ) {
    dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")
  } else {
    dflt_row_lbl <- if (is.null(avar)) "count" else avar
  }

  if (is.null(afun)) {
    afun <- count
  }

  if (is.null(avar)) {
    avar <- names(data)[1]
  }
  fakeres <- afun(data[[avar]], ...)
  multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups
  ## this is before we plug in the default so if not specified by the user
  ## explicitly, row_labels is NULL at this point.
  if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) {
    stop(
      "Length of row_labels (",
      length(row_labels),
      ") does not agree with number of rows generated by analysis function (",
      n_cells_res(fakeres),
      ")."
    )
  }

  if (is.null(row_labels)) {
    row_labels <- dflt_row_lbl
  }

  lyt <- basic_table(
    title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    prov_footer = prov_footer,
    show_colcounts = show_colcounts
  )

  for (var in col_vars) lyt <- split_cols_by(lyt, var)

  for (var in head(row_vars, -1)) {
    lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL)
    if (summarize_groups) {
      lyt <- summarize_row_groups(lyt)
    }
  }

  tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character()
  if (length(row_vars) > 0) {
    if (!multirow) {
      ## in the single row in splitting case, we use the row label as the topleft
      ## and the split values as the row labels for a more compact apeparance
      tleft <- row_labels
      row_labels <- NA_character_
      lyt <- split_rows_by(
        lyt, tail(row_vars, 1),
        split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden"
      )
    } else {
      lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL)
    }
    if (summarize_groups) {
      lyt <- summarize_row_groups(lyt)
    }
  }
  inner_afun <- .quick_afun(afun, row_labels)
  lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...))
  lyt <- append_topleft(lyt, tleft)
}

#' @rdname qtable_layout
#' @export
qtable <- function(data,
                   row_vars = character(),
                   col_vars = character(),
                   avar = NULL,
                   row_labels = NULL,
                   afun = NULL,
                   summarize_groups = FALSE,
                   title = "",
                   subtitles = character(),
                   main_footer = character(),
                   prov_footer = character(),
                   show_colcounts = TRUE,
                   drop_levels = TRUE,
                   ...) {
  ## this involves substitution so it needs to appear in both functions. Gross but true.
  subafun <- substitute(afun)
  if (
    is.name(subafun) && is.function(afun) &&
      ## this is gross. basically testing
      ## if the symbol we have corresponds
      ## in some meaningful way to the function
      ## we will be calling.
      identical(
        mget(
          as.character(subafun),
          mode = "function", envir = parent.frame(1), ifnotfound = list(NULL), inherits = TRUE
        )[[1]],
        afun
      )
  ) {
    dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")
  } else {
    dflt_row_lbl <- if (is.null(avar)) "count" else avar
  }

  lyt <- qtable_layout(
    data = data,
    row_vars = row_vars,
    col_vars = col_vars,
    avar = avar,
    row_labels = row_labels,
    afun = afun,
    summarize_groups = summarize_groups,
    title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    prov_footer = prov_footer,
    show_colcounts = show_colcounts,
    drop_levels = drop_levels,
    ...,
    .default_rlabel = dflt_row_lbl
  )
  build_table(lyt, data)
}

label_pos_values <- c("hidden", "visible", "topleft")

#' @name internal_methods
#' @rdname int_methods
NULL

#' Combine `SplitVector` objects
#'
#' @param x (`SplitVector`)\cr a `SplitVector` object.
#' @param ... splits or `SplitVector` objects.
#'
#' @return Various, but should be considered implementation details.
#'
#' @rdname int_methods
#' @exportMethod c
setMethod("c", "SplitVector", function(x, ...) {
  arglst <- list(...)
  stopifnot(all(sapply(arglst, is, "Split")))
  tmp <- c(unclass(x), arglst)
  SplitVector(lst = tmp)
})

## split_rows and split_cols are "recursive method stacks" which follow
## the general pattern of accept object -> call add_*_split on slot of object ->
## update object with value returned from slot method, return object.
##
## Thus each of the methods is idempotent, returning an updated object of the
## same class it was passed. The exception for idempotency is the NULL method
## which constructs a PreDataTableLayouts object with the specified split in the
## correct place.

## The cascading (by class) in this case is as follows for the row case:
## PreDataTableLayouts -> PreDataRowLayout -> SplitVector
#' @param cmpnd_fun (`function`)\cr intended for internal use.
#' @param pos (`numeric(1)`)\cr intended for internal use.
#' @param spl (`Split`)\cr the split.
#'
#' @rdname int_methods
setGeneric(
  "split_rows",
  function(lyt = NULL, spl, pos,
           cmpnd_fun = AnalyzeMultiVars) {
    standardGeneric("split_rows")
  }
)

#' @rdname int_methods
setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
  lifecycle::deprecate_warn(
    when = "0.3.8",
    what = I("split_rows(NULL)"),
    with = "basic_table()",
    details = "Initializing layouts via `NULL` is no longer supported."
  )
  rl <- PreDataRowLayout(SplitVector(spl))
  cl <- PreDataColLayout()
  PreDataTableLayouts(rlayout = rl, clayout = cl)
})

#' @rdname int_methods
setMethod(
  "split_rows", "PreDataRowLayout",
  function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
    stopifnot(pos > 0 && pos <= length(lyt) + 1)
    tmp <- if (pos <= length(lyt)) {
      split_rows(lyt[[pos]], spl, pos, cmpnd_fun)
    } else {
      if (pos != 1 && has_force_pag(spl)) {
        stop("page_by splits cannot have top-level siblings",
          call. = FALSE
        )
      }
      SplitVector(spl)
    }
    lyt[[pos]] <- tmp
    lyt
  }
)

is_analysis_spl <- function(spl) {
  is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars")
}

## note "pos" is ignored here because it is for which nest-chain
## spl should be placed in, NOIT for where in that chain it should go
#' @rdname int_methods
setMethod(
  "split_rows", "SplitVector",
  function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
    ## if(is_analysis_spl(spl) &&
    ##    is_analysis_spl(last_rowsplit(lyt))) {
    ##     return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun))
    ## }

    if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) {
      stop("page_by splits cannot be nested within non-page_by splits",
        call. = FALSE
      )
    }
    tmp <- c(unclass(lyt), spl)
    SplitVector(lst = tmp)
  }
)

#' @rdname int_methods
setMethod(
  "split_rows", "PreDataTableLayouts",
  function(lyt, spl, pos) {
    rlyt <- rlayout(lyt)
    addtl <- FALSE
    split_label <- obj_label(spl)
    if (
      is(spl, "Split") && ## exclude existing tables that are being tacked in
        identical(label_position(spl), "topleft") &&
        length(split_label) == 1 && nzchar(split_label)
    ) {
      addtl <- TRUE
      ##        label_position(spl) <- "hidden"
    }

    rlyt <- split_rows(rlyt, spl, pos)
    rlayout(lyt) <- rlyt
    if (addtl) {
      lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt)))
    }
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "split_rows", "ANY",
  function(lyt, spl, pos) {
    stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.")
  }
)

## cmpnd_last_rowsplit =====

#' @rdname int_methods
#'
#' @param constructor (`function`)\cr constructor function.
setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit"))

#' @rdname int_methods
setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) {
  stop("no existing splits to compound with. contact the maintainer") # nocov
})

#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "PreDataRowLayout",
  function(lyt, spl, constructor) {
    pos <- length(lyt)
    tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor)
    lyt[[pos]] <- tmp
    lyt
  }
)
#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "SplitVector",
  function(lyt, spl, constructor) {
    pos <- length(lyt)
    lst <- lyt[[pos]]
    tmp <- if (is(lst, "CompoundSplit")) {
      spl_payload(lst) <- c(
        .uncompound(spl_payload(lst)),
        .uncompound(spl)
      )
      obj_name(lst) <- make_ma_name(spl = lst)
      lst
      ## XXX never reached because AnalzyeMultiVars inherits from
      ## CompoundSplit???
    } else {
      constructor(.payload = list(lst, spl))
    }
    lyt[[pos]] <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "PreDataTableLayouts",
  function(lyt, spl, constructor) {
    rlyt <- rlayout(lyt)
    rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor)
    rlayout(lyt) <- rlyt
    lyt
  }
)
#' @rdname int_methods
setMethod(
  "cmpnd_last_rowsplit", "ANY",
  function(lyt, spl, constructor) {
    stop(
      "nope. can't do cmpnd_last_rowsplit to that (",
      class(lyt), "). contact the maintaner."
    )
  }
)

## split_cols ====

#' @rdname int_methods
setGeneric(
  "split_cols",
  function(lyt = NULL, spl, pos) {
    standardGeneric("split_cols")
  }
)

#' @rdname int_methods
setMethod("split_cols", "NULL", function(lyt, spl, pos) {
  lifecycle::deprecate_warn(
    when = "0.3.8",
    what = I("split_cols(NULL)"),
    with = "basic_table()",
    details = "Initializing layouts via `NULL` is no longer supported."
  )
  cl <- PreDataColLayout(SplitVector(spl))
  rl <- PreDataRowLayout()
  PreDataTableLayouts(rlayout = rl, clayout = cl)
})

#' @rdname int_methods
setMethod(
  "split_cols", "PreDataColLayout",
  function(lyt, spl, pos) {
    stopifnot(pos > 0 && pos <= length(lyt) + 1)
    tmp <- if (pos <= length(lyt)) {
      split_cols(lyt[[pos]], spl, pos)
    } else {
      SplitVector(spl)
    }

    lyt[[pos]] <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "split_cols", "SplitVector",
  function(lyt, spl, pos) {
    tmp <- c(lyt, spl)
    SplitVector(lst = tmp)
  }
)

#' @rdname int_methods
setMethod(
  "split_cols", "PreDataTableLayouts",
  function(lyt, spl, pos) {
    rlyt <- lyt@col_layout
    rlyt <- split_cols(rlyt, spl, pos)
    lyt@col_layout <- rlyt
    lyt
  }
)

#' @rdname int_methods
setMethod(
  "split_cols", "ANY",
  function(lyt, spl, pos) {
    stop(
      "nope. can't add a col split to that (", class(lyt),
      "). contact the maintaner."
    )
  }
)

# Constructors =====

## Pipe-able functions to add the various types of splits to the current layout
## for both row and column.  These all act as wrappers to the split_cols and
## split_rows method stacks.

#' Declaring a column-split based on levels of a variable
#'
#' Will generate children for each subset of a categorical variable.
#'
#' @inheritParams lyt_args
#' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference.
#'
#' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()].
#'
#' @inheritSection custom_split_funs Custom Splitting Function Details
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' # Let's look at the splits in more detail
#'
#' lyt1 <- basic_table() %>% split_cols_by("ARM")
#' lyt1
#'
#' # add an analysis (summary)
#' lyt2 <- lyt1 %>%
#'   analyze(c("AGE", "COUNTRY"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#' lyt2
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' @examplesIf require(dplyr)
#' # By default sequentially adding layouts results in nesting
#' library(dplyr)
#'
#' DM_MF <- DM %>%
#'   filter(SEX %in% c("M", "F")) %>%
#'   mutate(SEX = droplevels(SEX))
#'
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   analyze(c("AGE", "COUNTRY"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#' lyt3
#'
#' tbl3 <- build_table(lyt3, DM_MF)
#' tbl3
#'
#' # nested=TRUE vs not
#' lyt4 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX", split_fun = drop_split_levels) %>%
#'   split_rows_by("RACE", split_fun = drop_split_levels) %>%
#'   analyze("AGE")
#' lyt4
#'
#' tbl4 <- build_table(lyt4, DM)
#' tbl4
#'
#' lyt5 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX", split_fun = drop_split_levels) %>%
#'   analyze("AGE") %>%
#'   split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>%
#'   analyze("AGE")
#' lyt5
#'
#' tbl5 <- build_table(lyt5, DM)
#' tbl5
#'
#' @author Gabriel Becker
#' @export
split_cols_by <- function(lyt,
                          var,
                          labels_var = var,
                          split_label = var,
                          split_fun = NULL,
                          format = NULL,
                          nested = TRUE,
                          child_labels = c("default", "visible", "hidden"),
                          extra_args = list(),
                          ref_group = NULL,
                          show_colcounts = FALSE,
                          colcount_format = NULL) { ## ,
  if (is.null(ref_group)) {
    spl <- VarLevelSplit(
      var = var,
      split_label = split_label,
      labels_var = labels_var,
      split_format = format,
      child_labels = child_labels,
      split_fun = split_fun,
      extra_args = extra_args,
      show_colcounts = show_colcounts,
      colcount_format = colcount_format
    )
  } else {
    spl <- VarLevWBaselineSplit(
      var = var,
      ref_group = ref_group,
      split_label = split_label,
      split_fun = split_fun,
      labels_var = labels_var,
      split_format = format,
      show_colcounts = show_colcounts,
      colcount_format = colcount_format
    )
  }
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

## .tl_indent ====

setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner"))

setMethod(
  ".tl_indent_inner", "PreDataTableLayouts",
  function(lyt) .tl_indent_inner(rlayout(lyt))
)
setMethod(
  ".tl_indent_inner", "PreDataRowLayout",
  function(lyt) {
    if (length(lyt) == 0 || length(lyt[[1]]) == 0) {
      0L
    } else {
      .tl_indent_inner(lyt[[length(lyt)]])
    }
  }
)

setMethod(
  ".tl_indent_inner", "SplitVector",
  function(lyt) {
    sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L
  }
) ## length(lyt)  - 1L)

.tl_indent <- function(lyt, nested = TRUE) {
  if (!nested) {
    0L
  } else {
    .tl_indent_inner(lyt)
  }
}

#' Add rows according to levels of a variable
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @inheritSection custom_split_funs Custom Splitting Function Details
#'
#' @note
#' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor
#' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very
#' informative, but that will change in the future.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE", split_fun = drop_split_levels) %>%
#'   analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE") %>%
#'   analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   summarize_row_groups(label_fstr = "Overall (N)") %>%
#'   split_rows_by("RACE",
#'     split_label = "Ethnicity", labels_var = "ethn_lab",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
#'   analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
#'
#' lyt3
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' DM2 <- DM %>%
#'   filter(SEX %in% c("M", "F")) %>%
#'   mutate(
#'     SEX = droplevels(SEX),
#'     gender_lab = c(
#'       "F" = "Female", "M" = "Male",
#'       "U" = "Unknown",
#'       "UNDIFFERENTIATED" = "Undifferentiated"
#'     )[SEX],
#'     ethn_lab = c(
#'       "ASIAN" = "Asian",
#'       "BLACK OR AFRICAN AMERICAN" = "Black or African American",
#'       "WHITE" = "White",
#'       "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native",
#'       "MULTIPLE" = "Multiple",
#'       "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" =
#'         "Native Hawaiian or Other Pacific Islander",
#'       "OTHER" = "Other", "UNKNOWN" = "Unknown"
#'     )[RACE]
#'   )
#'
#' tbl3 <- build_table(lyt3, DM2)
#' tbl3
#'
#' @author Gabriel Becker
#' @export
split_rows_by <- function(lyt,
                          var,
                          labels_var = var,
                          split_label = var,
                          split_fun = NULL,
                          format = NULL,
                          na_str = NA_character_,
                          nested = TRUE,
                          child_labels = c("default", "visible", "hidden"),
                          label_pos = "hidden",
                          indent_mod = 0L,
                          page_by = FALSE,
                          page_prefix = split_label,
                          section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  spl <- VarLevelSplit(
    var = var,
    split_label = split_label,
    label_pos = label_pos,
    labels_var = labels_var,
    split_fun = split_fun,
    split_format = format,
    split_na_str = na_str,
    child_labels = child_labels,
    indent_mod = indent_mod,
    page_prefix = if (page_by) page_prefix else NA_character_,
    section_div = section_div
  )

  pos <- next_rpos(lyt, nested)
  ret <- split_rows(lyt, spl, pos)

  ret
}

#' Associate multiple variables with columns
#'
#' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis.
#' When we need columns to reflect different variables entirely, rather than different levels of a single
#' variable, we use `split_cols_by_multivar`.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @seealso [analyze_colvars()]
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))
#'
#' ## toy example where we take the mean of the first variable and the
#' ## count of >.5 for the second.
#' colfuns <- list(
#'   function(x) in_rows(mean = mean(x), .formats = "xx.x"),
#'   function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx")
#' )
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("value", "pctdiff")) %>%
#'   split_rows_by("RACE",
#'     split_label = "ethnicity",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze_colvars(afun = colfuns)
#' lyt
#'
#' tbl <- build_table(lyt, ANL)
#' tbl
#'
#' @author Gabriel Becker
#' @export
split_cols_by_multivar <- function(lyt,
                                   vars,
                                   split_fun = NULL,
                                   varlabels = vars,
                                   varnames = NULL,
                                   nested = TRUE,
                                   extra_args = list(),
                                   ## for completeness even though it doesn't make sense
                                   show_colcounts = FALSE,
                                   colcount_format = NULL) {
  spl <- MultiVarSplit(
    vars = vars, split_label = "",
    varlabels = varlabels,
    varnames = varnames,
    split_fun = split_fun,
    extra_args = extra_args,
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

#' Associate multiple variables with rows
#'
#' When we need rows to reflect different variables rather than different
#' levels of a single variable, we use `split_rows_by_multivar`.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_rows_by return
#'
#' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of
#'   split on a column basis.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by_multivar(c("SEX", "STRATA1")) %>%
#'   summarize_row_groups() %>%
#'   analyze(c("AGE", "SEX"))
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
split_rows_by_multivar <- function(lyt,
                                   vars,
                                   split_fun = NULL,
                                   split_label = "",
                                   varlabels = vars,
                                   format = NULL,
                                   na_str = NA_character_,
                                   nested = TRUE,
                                   child_labels = c("default", "visible", "hidden"),
                                   indent_mod = 0L,
                                   section_div = NA_character_,
                                   extra_args = list()) {
  child_labels <- match.arg(child_labels)
  spl <- MultiVarSplit(
    vars = vars, split_label = split_label, varlabels,
    split_format = format,
    split_na_str = na_str,
    child_labels = child_labels,
    indent_mod = indent_mod,
    split_fun = split_fun,
    section_div = section_div,
    extra_args = extra_args
  )
  pos <- next_rpos(lyt, nested)
  split_rows(lyt, spl, pos)
}

#' Split on static or dynamic cuts of the data
#'
#' Create columns (or row splits) based on values (such as quartiles) of `var`.
#'
#' @inheritParams lyt_args
#'
#' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*,
#' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect
#' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under.
#'
#' @inherit split_cols_by return
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' # split_cols_by_cuts
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_cuts("AGE",
#'     split_label = "Age",
#'     cuts = c(0, 25, 35, 1000),
#'     cutlabels = c("young", "medium", "old")
#'   ) %>%
#'   analyze(c("BMRKR2", "STRATA2")) %>%
#'   append_topleft("counts")
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' # split_rows_by_cuts
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by_cuts("AGE",
#'     split_label = "Age",
#'     cuts = c(0, 25, 35, 1000),
#'     cutlabels = c("young", "medium", "old")
#'   ) %>%
#'   analyze(c("BMRKR2", "STRATA2")) %>%
#'   append_topleft("counts")
#'
#'
#' tbl2 <- build_table(lyt2, ex_adsl)
#' tbl2
#'
#' # split_cols_by_quartiles
#'
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_quartiles("AGE", split_label = "Age") %>%
#'   analyze(c("BMRKR2", "STRATA2")) %>%
#'   append_topleft("counts")
#'
#' tbl3 <- build_table(lyt3, ex_adsl)
#' tbl3
#'
#' # split_rows_by_quartiles
#' lyt4 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by_quartiles("AGE", split_label = "Age") %>%
#'   analyze("BMRKR2") %>%
#'   append_topleft(c("Age Quartiles", " Counts BMRKR2"))
#'
#' tbl4 <- build_table(lyt4, ex_adsl)
#' tbl4
#'
#' # split_cols_by_cutfun
#' cutfun <- function(x) {
#'   cutpoints <- c(
#'     min(x),
#'     mean(x),
#'     max(x)
#'   )
#'
#'   names(cutpoints) <- c("", "Younger", "Older")
#'   cutpoints
#' }
#'
#' lyt5 <- basic_table() %>%
#'   split_cols_by_cutfun("AGE", cutfun = cutfun) %>%
#'   analyze("SEX")
#'
#' tbl5 <- build_table(lyt5, ex_adsl)
#' tbl5
#'
#' # split_rows_by_cutfun
#' lyt6 <- basic_table() %>%
#'   split_cols_by("SEX") %>%
#'   split_rows_by_cutfun("AGE", cutfun = cutfun) %>%
#'   analyze("BMRKR2")
#'
#' tbl6 <- build_table(lyt6, ex_adsl)
#' tbl6
#'
#' @author Gabriel Becker
#' @export
#' @rdname varcuts
split_cols_by_cuts <- function(lyt, var, cuts,
                               cutlabels = NULL,
                               split_label = var,
                               nested = TRUE,
                               cumulative = FALSE,
                               show_colcounts = FALSE,
                               colcount_format = NULL) {
  spl <- make_static_cut_split(
    var = var,
    split_label = split_label,
    cuts = cuts,
    cutlabels = cutlabels,
    cumulative = cumulative,
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  ## if(cumulative)
  ##     spl = as(spl, "CumulativeCutSplit")
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_rows_by_cuts <- function(lyt, var, cuts,
                               cutlabels = NULL,
                               split_label = var,
                               format = NULL,
                               na_str = NA_character_,
                               nested = TRUE,
                               cumulative = FALSE,
                               label_pos = "hidden",
                               section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  ##    VarStaticCutSplit(
  spl <- make_static_cut_split(var, split_label,
    cuts = cuts,
    cutlabels = cutlabels,
    split_format = format,
    split_na_str = na_str,
    label_pos = label_pos,
    cumulative = cumulative,
    section_div = section_div
  )
  ## if(cumulative)
  ##     spl = as(spl, "CumulativeCutSplit")
  pos <- next_rpos(lyt, nested)
  split_rows(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_cols_by_cutfun <- function(lyt, var,
                                 cutfun = qtile_cuts,
                                 cutlabelfun = function(x) NULL,
                                 split_label = var,
                                 nested = TRUE,
                                 extra_args = list(),
                                 cumulative = FALSE,
                                 show_colcounts = FALSE,
                                 colcount_format = NULL) {
  spl <- VarDynCutSplit(var, split_label,
    cutfun = cutfun,
    cutlabelfun = cutlabelfun,
    extra_args = extra_args,
    cumulative = cumulative,
    label_pos = "hidden",
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  pos <- next_cpos(lyt, nested)
  split_cols(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_cols_by_quartiles <- function(lyt, var, split_label = var,
                                    nested = TRUE,
                                    extra_args = list(),
                                    cumulative = FALSE,
                                    show_colcounts = FALSE,
                                    colcount_format = NULL) {
  split_cols_by_cutfun(
    lyt = lyt,
    var = var,
    split_label = split_label,
    cutfun = qtile_cuts,
    cutlabelfun = function(x) {
      c(
        "[min, Q1]",
        "(Q1, Q2]",
        "(Q2, Q3]",
        "(Q3, max]"
      )
    },
    nested = nested,
    extra_args = extra_args,
    cumulative = cumulative,
    show_colcounts = show_colcounts,
    colcount_format = colcount_format
  )
  ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,
  ##                      cutlabelfun = function(x) c("[min, Q1]",
  ##                                                "(Q1, Q2]",
  ##                                                "(Q2, Q3]",
  ##                                                "(Q3, max]"),
  ##                      split_format = format,
  ##                      extra_args = extra_args,
  ##                      cumulative = cumulative,
  ##                      label_pos = "hidden")
  ## pos = next_cpos(lyt, nested)
  ## split_cols(lyt, spl, pos)
}

#' @export
#' @rdname varcuts
split_rows_by_quartiles <- function(lyt, var, split_label = var,
                                    format = NULL,
                                    na_str = NA_character_,
                                    nested = TRUE,
                                    child_labels = c("default", "visible", "hidden"),
                                    extra_args = list(),
                                    cumulative = FALSE,
                                    indent_mod = 0L,
                                    label_pos = "hidden",
                                    section_div = NA_character_) {
  split_rows_by_cutfun(
    lyt = lyt,
    var = var,
    split_label = split_label,
    format = format,
    na_str = na_str,
    cutfun = qtile_cuts,
    cutlabelfun = function(x) {
      c(
        "[min, Q1]",
        "(Q1, Q2]",
        "(Q2, Q3]",
        "(Q3, max]"
      )
    },
    nested = nested,
    child_labels = child_labels,
    extra_args = extra_args,
    cumulative = cumulative,
    indent_mod = indent_mod,
    label_pos = label_pos,
    section_div = section_div
  )

  ## label_pos <- match.arg(label_pos, label_pos_values)
  ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,
  ##                      cutlabelfun = ,
  ##                      split_format = format,
  ##                      child_labels = child_labels,
  ##                      extra_args = extra_args,
  ##                      cumulative = cumulative,
  ##                      indent_mod = indent_mod,
  ##                      label_pos = label_pos)
  ## pos = next_rpos(lyt, nested)
  ## split_rows(lyt, spl, pos)
}

qtile_cuts <- function(x) {
  ret <- quantile(x)
  names(ret) <- c(
    "",
    "1st qrtile",
    "2nd qrtile",
    "3rd qrtile",
    "4th qrtile"
  )
  ret
}

#' @export
#' @rdname varcuts
split_rows_by_cutfun <- function(lyt, var,
                                 cutfun = qtile_cuts,
                                 cutlabelfun = function(x) NULL,
                                 split_label = var,
                                 format = NULL,
                                 na_str = NA_character_,
                                 nested = TRUE,
                                 child_labels = c("default", "visible", "hidden"),
                                 extra_args = list(),
                                 cumulative = FALSE,
                                 indent_mod = 0L,
                                 label_pos = "hidden",
                                 section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  spl <- VarDynCutSplit(var, split_label,
    cutfun = cutfun,
    cutlabelfun = cutlabelfun,
    split_format = format,
    split_na_str = na_str,
    child_labels = child_labels,
    extra_args = extra_args,
    cumulative = cumulative,
    indent_mod = indent_mod,
    label_pos = label_pos,
    section_div = section_div
  )
  pos <- next_rpos(lyt, nested)
  split_rows(lyt, spl, pos)
}

#' .spl_context within analysis and split functions
#'
#' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function
#' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for
#' [split_rows_by()]).
#'
#' @details
#' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within
#' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set
#' of) rows the analysis function is creating, although the information is in a slightly different form. Each split
#' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented
#' via the following columns:
#'
#' \describe{
#'   \item{split}{The name of the split (often the variable being split).}
#'   \item{value}{The string representation of the value at that split (`split`).}
#'   \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path
#'     defined by the combination of `split` and `value` of this row *and all rows above this row*.}
#'   \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).}
#'   \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns
#'     (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's
#'     `full_parent_df` corresponding to the column.}
#'   \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the
#'     column path together.}
#'   \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df`
#'     for the column currently being created by the analysis function.}
#'   \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external
#'     data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.}
#'   \item{cur_col_n}{Integer column containing the observation counts for that split.}
#'   \item{cur_col_split}{Current column split names. This is recovered from the current column path.}
#'   \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.}
#' }
#'
#' @note
#' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame
#' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the
#' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the
#' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()].
#'
#' @name spl_context
NULL

#' Additional parameters within analysis and content functions (`afun`/`cfun`)
#'
#' @description
#' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()],
#' respectively. These parameters grant access to relevant information like the row split structure (see
#' [spl_context]) and the predefined baseline (`.ref_group`).
#'
#' @details
#' We list and describe all the parameters that can be added to a custom analysis function below:
#'
#' \describe{
#'   \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.}
#'   \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.}
#'   \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no
#'     column-based subsetting).}
#'   \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based
#'     subsetting).}
#'   \item{.var}{Variable being analyzed.}
#'   \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting
#'     defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}
#'   \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting
#'     defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}
#'   \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.}
#'   \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state.
#'     See [spl_context].}
#'   \item{.alt_df_row}{`data.frame`, i.e. the `alt_count_df` after row splitting. It can be used with
#'     `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`.
#'     It can be an empty table if all the entries are filtered out.}
#'   \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same
#'     faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs`
#'     in [analyze()]). Similarly to `.alt_df_row`, it can be an empty table if all the entries are filtered out.}
#'   \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.}
#'   \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs
#'     if `alt_counts_df` is used (see [build_table()]).}
#' }
#'
#' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be
#'   treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during
#'   data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is
#'   provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present.
#'
#' @name additional_fun_params
NULL

#' Generate rows analyzing variables across columns
#'
#' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by
#' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting,
#' the tabulation will occur at the current/next level of nesting by default.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @details
#' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a
#' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the
#' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`.
#'
#' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the
#' function accepts will change the behavior when tabulation is performed as follows:
#'
#' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant
#'   column (from `var` here) of the raw data being used to build the table.
#' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of
#'   the raw data being tabulated.
#'
#' In addition to differentiation on the first argument, the analysis function can optionally accept a number of
#' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation
#' machinery. These are listed and described in [additional_fun_params].
#'
#' @note None of the arguments described in the Details section can be overridden via `extra_args` or when calling
#'   [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()].
#'   Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and
#'   the unmodified values provided by the tabulation framework.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
#' lyt
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze(head(names(iris), -1), afun = function(x) {
#'     list(
#'       "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "range" = rcell(diff(range(x)), format = "xx.xx")
#'     )
#'   })
#' lyt2
#'
#' tbl2 <- build_table(lyt2, iris)
#' tbl2
#'
#' @author Gabriel Becker
#' @export
analyze <- function(lyt,
                    vars,
                    afun = simple_analysis,
                    var_labels = vars,
                    table_names = vars,
                    format = NULL,
                    na_str = NA_character_,
                    nested = TRUE,
                    ## can't name this na_rm symbol conflict with possible afuns!!
                    inclNAs = FALSE,
                    extra_args = list(),
                    show_labels = c("default", "visible", "hidden"),
                    indent_mod = 0L,
                    section_div = NA_character_) {
  show_labels <- match.arg(show_labels)
  subafun <- substitute(afun)
  if (
    is.name(subafun) &&
      is.function(afun) &&
      ## this is gross. basically testing
      ## if the symbol we have corresponds
      ## in some meaningful way to the function
      ## we will be calling.
      identical(
        mget(
          as.character(subafun),
          mode = "function",
          ifnotfound = list(NULL),
          inherits = TRUE
        )[[1]], afun
      )
  ) {
    defrowlab <- as.character(subafun)
  } else {
    defrowlab <- var_labels
  }

  spl <- AnalyzeMultiVars(vars, var_labels,
    afun = afun,
    split_format = format,
    split_na_str = na_str,
    defrowlab = defrowlab,
    inclNAs = inclNAs,
    extra_args = extra_args,
    indent_mod = indent_mod,
    child_names = table_names,
    child_labels = show_labels,
    section_div = section_div
  )

  if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) {
    cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars)
  } else {
    ## analysis compounding now done in split_rows
    pos <- next_rpos(lyt, nested)
    split_rows(lyt, spl, pos)
  }
}

get_acolvar_name <- function(lyt) {
  ## clyt <- clayout(lyt)
  ## stopifnot(length(clyt) == 1L)
  ## vec = clyt[[1]]
  ## vcls = vapply(vec, class, "")
  ## pos = max(which(vcls ==  "MultiVarSplit"))
  paste(c("ac", get_acolvar_vars(lyt)), collapse = "_")
}

get_acolvar_vars <- function(lyt) {
  clyt <- clayout(lyt)
  stopifnot(length(clyt) == 1L)
  vec <- clyt[[1]]
  vcls <- vapply(vec, class, "")
  pos <- which(vcls == "MultiVarSplit")
  if (length(pos) > 0) {
    spl_payload(vec[[pos]])
  } else {
    "non_multivar"
  }
}

#' Generate rows analyzing different variables across columns
#'
#' @inheritParams lyt_args
#' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list
#'   will be repped out as needed and matched by position with the columns during tabulation. This functions
#'   accepts the same parameters as [analyze()] like `afun` and `format`. For further information see
#'   [additional_fun_params].
#'
#' @inherit split_cols_by return
#'
#' @seealso [split_cols_by_multivar()]
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))
#'
#' ## toy example where we take the mean of the first variable and the
#' ## count of >.5 for the second.
#' colfuns <- list(
#'   function(x) rcell(mean(x), format = "xx.x"),
#'   function(x) rcell(sum(x > .5), format = "xx")
#' )
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("value", "pctdiff")) %>%
#'   split_rows_by("RACE",
#'     split_label = "ethnicity",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze_colvars(afun = colfuns)
#' lyt
#'
#' tbl <- build_table(lyt, ANL)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("value", "pctdiff"),
#'     varlabels = c("Measurement", "Pct Diff")
#'   ) %>%
#'   split_rows_by("RACE",
#'     split_label = "ethnicity",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze_colvars(afun = mean, format = "xx.xx")
#'
#' tbl2 <- build_table(lyt2, ANL)
#' tbl2
#'
#' @author Gabriel Becker
#' @export
analyze_colvars <- function(lyt,
                            afun,
                            format = NULL,
                            na_str = NA_character_,
                            nested = TRUE,
                            extra_args = list(),
                            indent_mod = 0L,
                            inclNAs = FALSE) {
  if (is.function(afun)) {
    subafun <- substitute(afun)
    if (
      is.name(subafun) &&
        is.function(afun) &&
        ## this is gross. basically testing
        ## if the symbol we have corresponds
        ## in some meaningful way to the function
        ## we will be calling.
        identical(
          mget(
            as.character(subafun),
            mode = "function",
            ifnotfound = list(NULL),
            inherits = TRUE
          )[[1]],
          afun
        )
    ) {
      defrowlab <- as.character(subafun)
    } else {
      defrowlab <- ""
    }
    afun <- lapply(
      get_acolvar_vars(lyt),
      function(x) afun
    )
  } else {
    defrowlab <- ""
  }
  spl <- AnalyzeColVarSplit(
    afun = afun,
    defrowlab = defrowlab,
    split_format = format,
    split_na_str = na_str,
    split_name = get_acolvar_name(lyt),
    indent_mod = indent_mod,
    extra_args = extra_args,
    inclNAs = inclNAs
  )
  pos <- next_rpos(lyt, nested, for_analyze = TRUE)
  split_rows(lyt, spl, pos)
}

## Add a total column at the next **top level** spot in
## the column layout.

#' Add overall column
#'
#' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits.
#' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @seealso [add_overall_level()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_overall_col("All Patients") %>%
#'   analyze("AGE")
#' lyt
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
add_overall_col <- function(lyt, label) {
  spl <- AllSplit(label)
  split_cols(
    lyt,
    spl,
    next_cpos(lyt, FALSE)
  )
}

## add_row_summary ====

#' @inheritParams lyt_args
#'
#' @export
#'
#' @rdname int_methods
setGeneric(
  ".add_row_summary",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    standardGeneric(".add_row_summary")
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "PreDataTableLayouts",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    tmp <- .add_row_summary(rlayout(lyt), label, cfun,
      child_labels = child_labels,
      cformat = cformat,
      cna_str = cna_str,
      indent_mod = indent_mod,
      cvar = cvar,
      extra_args = extra_args
    )
    rlayout(lyt) <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "PreDataRowLayout",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) {
      ## XXX ignoring indent mod here
      rt <- root_spl(lyt)
      rt <- .add_row_summary(rt,
        label,
        cfun,
        child_labels = child_labels,
        cformat = cformat,
        cna_str = cna_str,
        cvar = cvar,
        extra_args = extra_args
      )
      root_spl(lyt) <- rt
    } else {
      ind <- length(lyt)
      tmp <- .add_row_summary(lyt[[ind]], label, cfun,
        child_labels = child_labels,
        cformat = cformat,
        cna_str = cna_str,
        indent_mod = indent_mod,
        cvar = cvar,
        extra_args = extra_args
      )
      lyt[[ind]] <- tmp
    }
    lyt
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "SplitVector",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    ind <- length(lyt)
    if (ind == 0) stop("no split to add content rows at")
    spl <- lyt[[ind]]
    # if(is(spl, "AnalyzeVarSplit"))
    #     stop("can't add content rows to analyze variable split")
    tmp <- .add_row_summary(spl,
      label,
      cfun,
      child_labels = child_labels,
      cformat = cformat,
      cna_str = cna_str,
      indent_mod = indent_mod,
      cvar = cvar,
      extra_args = extra_args
    )
    lyt[[ind]] <- tmp
    lyt
  }
)

#' @rdname int_methods
setMethod(
  ".add_row_summary", "Split",
  function(lyt,
           label,
           cfun,
           child_labels = c("default", "visible", "hidden"),
           cformat = NULL,
           cna_str = "-",
           indent_mod = 0L,
           cvar = "",
           extra_args = list()) {
    child_labels <- match.arg(child_labels)
    #   lbl_kids = .labelkids_helper(child_labels)
    content_fun(lyt) <- cfun
    content_indent_mod(lyt) <- indent_mod
    content_var(lyt) <- cvar
    ## obj_format(lyt) = cformat
    content_format(lyt) <- cformat
    if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) {
      label_kids(lyt) <- child_labels
    }
    content_na_str <- cna_str
    content_extra_args(lyt) <- extra_args
    lyt
  }
)

.count_raw_constr <- function(var, format, label_fstr) {
  function(df, labelstr = "") {
    if (grepl("%s", label_fstr, fixed = TRUE)) {
      label <- sprintf(label_fstr, labelstr)
    } else {
      label <- label_fstr
    }
    if (is(df, "data.frame")) {
      if (!is.null(var) && nzchar(var)) {
        cnt <- sum(!is.na(df[[var]]))
      } else {
        cnt <- nrow(df)
      }
    } else { # df is the data column vector
      cnt <- sum(!is.na(df))
    }
    ret <- rcell(cnt,
      format = format,
      label = label
    )
    ret
  }
}

.count_wpcts_constr <- function(var, format, label_fstr) {
  function(df, labelstr = "", .N_col) {
    if (grepl("%s", label_fstr, fixed = TRUE)) {
      label <- sprintf(label_fstr, labelstr)
    } else {
      label <- label_fstr
    }
    if (is(df, "data.frame")) {
      if (!is.null(var) && nzchar(var)) {
        cnt <- sum(!is.na(df[[var]]))
      } else {
        cnt <- nrow(df)
      }
    } else { # df is the data column vector
      cnt <- sum(!is.na(df))
    }
    ## the formatter does the *100 so we don't here.
    ## TODO name elements of this so that ARD generation has access to them
    ## ret <- rcell(c(n = cnt, pct = cnt / .N_col),
    ret <- rcell(c(cnt, cnt / .N_col),
      format = format,
      label = label
    )
    ret
  }
}

.validate_cfuns <- function(fun) {
  if (is.list(fun)) {
    return(unlist(lapply(fun, .validate_cfuns)))
  }

  frmls <- formals(fun)
  ls_pos <- match("labelstr", names(frmls))
  if (is.na(ls_pos)) {
    stop("content functions must explicitly accept a 'labelstr' argument")
  }

  list(fun)
}

#' Analysis function to count levels of a factor with percentage of the column total
#'
#' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery.
#' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery.
#'
#' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor.
#'
#' @examples
#' counts_wpcts(DM$SEX, 400)
#'
#' @export
counts_wpcts <- function(x, .N_col) {
  if (!is.factor(x)) {
    stop(
      "using the 'counts_wpcts' analysis function requires factor data ",
      "to guarantee equal numbers of rows across all collumns, got class ",
      class(x), "."
    )
  }
  ret <- table(x)
  in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)")))
}

#' Add a content row of summary counts
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @details
#' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values
#' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of
#' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only
#' raw counts are used.
#'
#' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset
#' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept
#' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently
#' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]).
#'
#' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params]
#' that can be used in `cfun`.
#'
#' @examples
#' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
#'   summarize_row_groups(label_fstr = "%s (n)") %>%
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
#' lyt
#'
#' tbl <- build_table(lyt, DM2)
#' tbl
#'
#' row_paths_summary(tbl) # summary count is a content table
#'
#' ## use a cfun and extra_args to customize summarization
#' ## behavior
#' sfun <- function(x, labelstr, trim) {
#'   in_rows(
#'     c(mean(x, trim = trim), trim),
#'     .formats = "xx.x (xx.x%)",
#'     .labels = sprintf(
#'       "%s (Trimmed mean and trim %%)",
#'       labelstr
#'     )
#'   )
#' }
#'
#' lyt2 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
#'   summarize_row_groups("AGE",
#'     cfun = sfun,
#'     extra_args = list(trim = .2)
#'   ) %>%
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
#'   append_topleft(c("Country", "  Age"))
#'
#' tbl2 <- build_table(lyt2, DM2)
#' tbl2
#'
#' @author Gabriel Becker
#' @export
summarize_row_groups <- function(lyt,
                                 var = "",
                                 label_fstr = "%s",
                                 format = "xx (xx.x%)",
                                 na_str = "-",
                                 cfun = NULL,
                                 indent_mod = 0L,
                                 extra_args = list()) {
  if (is.null(cfun)) {
    if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) {
      cfun <- .count_raw_constr(var, format, label_fstr)
    } else {
      cfun <- .count_wpcts_constr(var, format, label_fstr)
    }
  }
  cfun <- .validate_cfuns(cfun)
  .add_row_summary(lyt,
    cfun = cfun,
    cformat = format,
    cna_str = na_str,
    indent_mod = indent_mod,
    cvar = var,
    extra_args = extra_args
  )
}

#' Add the column population counts to the header
#'
#' Add the data derived column counts.
#'
#' @details It is often the case that the the column counts derived from the
#'   input data to [build_table()] is not representative of the population counts.
#'   For example, if events are counted in the table and the header should
#'   display the number of subjects and not the total number of events.
#'
#' @inheritParams lyt_args
#'
#' @inherit split_cols_by return
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   split_rows_by("RACE", split_fun = drop_split_levels) %>%
#'   analyze("AGE", afun = function(x) list(min = min(x), max = max(x)))
#' lyt
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @author Gabriel Becker
#' @export
add_colcounts <- function(lyt, format = "(N=xx)") {
  if (is.null(lyt)) {
    lyt <- PreDataTableLayouts()
  }
  disp_ccounts(lyt) <- TRUE
  colcount_format(lyt) <- format
  lyt
}

## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting.
#' Add an already calculated table to the layout
#'
#' @inheritParams lyt_args
#' @inheritParams gen_args
#'
#' @inherit split_cols_by return
#'
#' @examples
#' lyt1 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = mean, format = "xx.xx")
#'
#' tbl1 <- build_table(lyt1, DM)
#' tbl1
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = sd, format = "xx.xx") %>%
#'   add_existing_table(tbl1)
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' table_structure(tbl2)
#' row_paths_summary(tbl2)
#'
#' @author Gabriel Becker
#' @export
add_existing_table <- function(lyt, tt, indent_mod = 0) {
  indent_mod(tt) <- indent_mod
  lyt <- split_rows(
    lyt,
    tt,
    next_rpos(lyt, nested = FALSE)
  )
  lyt
}

## takes_coln = function(f) {
##     stopifnot(is(f, "function"))
##     forms = names(formals(f))
##     res = ".N_col" %in% forms
##     res
## }

## takes_totn = function(f) {
##     stopifnot(is(f, "function"))
##     forms = names(formals(f))
##     res = ".N_total" %in% forms
##     res
## }

## use data to transform dynamic cuts to static cuts
#' @rdname int_methods
setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts"))

#' @rdname int_methods
setMethod("fix_dyncuts", "Split", function(spl, df) spl)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "VarDynCutSplit",
  function(spl, df) {
    var <- spl_payload(spl)
    varvec <- df[[var]]

    cfun <- spl_cutfun(spl)
    cuts <- cfun(varvec)
    cutlabels <- spl_cutlabelfun(spl)(cuts)
    if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) {
      cutlabels <- names(cuts)[-1]
    }

    ret <- make_static_cut_split(
      var = var, split_label = obj_label(spl),
      cuts = cuts, cutlabels = cutlabels,
      cumulative = spl_is_cmlcuts(spl)
    )
    ## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl),
    ##                   cuts = cuts, cutlabels = cutlabels)
    ## ## classes are tthe same structurally CumulativeCutSplit
    ## ## is just a sentinal so it can hit different make_subset_expr
    ## ## method
    ## if(spl_is_cmlcuts(spl))
    ##     ret = as(ret, "CumulativeCutSplit")
    ret
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "VTableTree",
  function(spl, df) spl
)

.fd_helper <- function(spl, df) {
  lst <- lapply(spl, fix_dyncuts, df = df)
  spl@.Data <- lst
  spl
}

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "PreDataRowLayout",
  function(spl, df) {
    #   rt = root_spl(spl)
    ret <- .fd_helper(spl, df)
    #    root_spl(ret) = rt
    ret
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "PreDataColLayout",
  function(spl, df) {
    #   rt = root_spl(spl)
    ret <- .fd_helper(spl, df)
    #   root_spl(ret) = rt
    #   disp_ccounts(ret) = disp_ccounts(spl)
    #   colcount_format(ret) = colcount_format(spl)
    ret
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "SplitVector",
  function(spl, df) {
    .fd_helper(spl, df)
  }
)

#' @rdname int_methods
setMethod(
  "fix_dyncuts", "PreDataTableLayouts",
  function(spl, df) {
    rlayout(spl) <- fix_dyncuts(rlayout(spl), df)
    clayout(spl) <- fix_dyncuts(clayout(spl), df)
    spl
  }
)

## Manual column construction in a simple (seeming to the user) way.
#' Manual column declaration
#'
#' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given,
#'   the values of the second are nested within each value of the first, and so on.
#' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`.
#' @param ccount_format (`FormatSpec`)\cr the format to use when counts are displayed.
#'
#' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed
#'   table.
#'
#' @examples
#' # simple one level column space
#' rows <- lapply(1:5, function(i) {
#'   DataRow(rep(i, times = 3))
#' })
#' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c")))
#' tbl
#'
#' # manually declared nesting
#' tbl2 <- TableTree(
#'   kids = list(DataRow(as.list(1:4))),
#'   cinfo = manual_cols(
#'     Arm = c("Arm A", "Arm B"),
#'     Gender = c("M", "F")
#'   )
#' )
#' tbl2
#'
#' @author Gabriel Becker
#' @export
manual_cols <- function(..., .lst = list(...), ccount_format = NULL) {
  if (is.null(names(.lst))) {
    names(.lst) <- paste("colsplit", seq_along(.lst))
  }

  splvec <- SplitVector(lst = mapply(ManualSplit,
    levels = .lst,
    label = names(.lst)
  ))
  ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos(), global_cc_format = ccount_format)

  ret <- InstantiatedColumnInfo(treelyt = ctree)
  rm_all_colcounts(ret)
}


#' Set all column counts at all levels of nesting to NA
#'
#' @inheritParams gen_args
#'
#' @return `obj` with all column counts reset to missing
#'
#' @export
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   analyze("AGE")
#' tbl <- build_table(lyt, ex_adsl)
#'
#' # before
#' col_counts(tbl)
#' tbl <- rm_all_colcounts(tbl)
#' col_counts(tbl)
setGeneric("rm_all_colcounts", function(obj) standardGeneric("rm_all_colcounts"))

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "VTableTree",
  function(obj) {
    cinfo <- col_info(obj)
    cinfo <- rm_all_colcounts(cinfo)
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "InstantiatedColumnInfo",
  function(obj) {
    ctree <- coltree(obj)
    ctree <- rm_all_colcounts(ctree)
    coltree(obj) <- ctree
    obj
  }
)

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "LayoutColTree",
  function(obj) {
    obj@column_count <- NA_integer_
    tree_children(obj) <- lapply(tree_children(obj), rm_all_colcounts)
    obj
  }
)

#' @rdname rm_all_colcounts
#' @export
setMethod(
  "rm_all_colcounts", "LayoutColLeaf",
  function(obj) {
    obj@column_count <- NA_integer_
    obj
  }
)

#' Returns a function that coerces the return values of a function to a list
#'
#' @param f (`function`)\cr the function to wrap.
#'
#' @details
#' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an
#' otherwise identical wrapper function whose first argument is named `df`.
#'
#' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as
#' their first argument are passed the full subset data frame, while those which accept anything else notably
#' including `x` are passed only the relevant subset of the variable being analyzed.
#'
#' @return A function that returns a list of `CellValue` objects.
#'
#' @examples
#' summary(iris$Sepal.Length)
#'
#' f <- list_wrap_x(summary)
#' f(x = iris$Sepal.Length)
#'
#' f2 <- list_wrap_df(summary)
#' f2(df = iris$Sepal.Length)
#'
#' @author Gabriel Becker
#' @rdname list_wrap
#' @export
list_wrap_x <- function(f) {
  function(x, ...) {
    vs <- as.list(f(x, ...))
    ret <- mapply(
      function(v, nm) {
        rcell(v, label = nm)
      },
      v = vs,
      nm = names(vs)
    )
    ret
  }
}

#' @rdname list_wrap
#' @export
list_wrap_df <- function(f) {
  function(df, ...) {
    vs <- as.list(f(df, ...))
    ret <- mapply(
      function(v, nm) {
        rcell(v, label = nm)
      },
      v = vs,
      nm = names(vs)
    )
    ret
  }
}

#' Layout with 1 column and zero rows
#'
#' Every layout must start with a basic table.
#'
#' @inheritParams constr_args
#' @param show_colcounts (`logical(1)`)\cr Indicates whether the lowest level of
#'   applied to data. `NA`, the default, indicates that the `show_colcounts`
#'   argument(s) passed to the relevant calls to `split_cols_by*`
#'   functions. Non-missing values will override the behavior specified in
#'   column splitting layout instructions which create the lowest level, or
#'   leaf, columns.
#' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d
#'   where one component is a percent. This will also apply to any displayed higher
#'   level column counts where an explicit format was not specified. Defaults to `"(N=xx)"`. See Details below.
#' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split
#'   or division of the table will be highlighted by a line made of that character. See [section_div] for more
#'   information.
#'
#' @details
#' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`,
#' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always
#' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be,
#' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of
#' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list
#' of valid format labels to select from.
#'
#' @inherit split_cols_by return
#'
#' @note
#' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably
#'   strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as
#'   their percentage, even though the individual arm columns represent strict subsets of the "all patients" column.
#'
#' - Note that subtitles ([formatters::subtitles()]) and footers ([formatters::main_footer()] and
#' [formatters::prov_footer()]) that span more than one line can be supplied as a character vector to maintain
#' indentation on multiple lines.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   analyze("AGE", afun = mean)
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table(
#'   title = "Title of table",
#'   subtitles = c("a number", "of subtitles"),
#'   main_footer = "test footer",
#'   prov_footer = paste(
#'     "test.R program, executed at",
#'     Sys.time()
#'   )
#' ) %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", mean)
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' lyt3 <- basic_table(
#'   show_colcounts = TRUE,
#'   colcount_format = "xx. (xx.%)"
#' ) %>%
#'   split_cols_by("ARM")
#'
#' @export
basic_table <- function(title = "",
                        subtitles = character(),
                        main_footer = character(),
                        prov_footer = character(),
                        show_colcounts = NA, # FALSE,
                        colcount_format = "(N=xx)",
                        header_section_div = NA_character_,
                        top_level_section_div = NA_character_,
                        inset = 0L) {
  inset <- as.integer(inset)
  if (is.na(inset) || inset < 0L) {
    stop("Got invalid table_inset value, must be an integer > 0")
  }
  .check_header_section_div(header_section_div)
  checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1)

  ret <- PreDataTableLayouts(
    title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    prov_footer = prov_footer,
    header_section_div = header_section_div,
    top_level_section_div = top_level_section_div,
    table_inset = as.integer(inset)
  )

  ## unconditional now, NA case is handled in cinfo construction
  disp_ccounts(ret) <- show_colcounts
  colcount_format(ret) <- colcount_format
  ## if (isTRUE(show_colcounts)) {
  ##   ret <- add_colcounts(ret, format = colcount_format)
  ## }
  ret
}

#' Append a description to the 'top-left' materials for the layout
#'
#' This function *adds* `newlines` to the current set of "top-left materials".
#'
#' @details
#' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content
#' displayed to the left of the column labels when the resulting tables are printed).
#'
#' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to
#' them either when they are added or when they are displayed.
#'
#' @inheritParams lyt_args
#' @param newlines (`character`)\cr the new line(s) to be added to the materials.
#'
#' @note
#' Currently, where in the construction of the layout this is called makes no difference, as it is independent of
#' the actual splitting keywords. This may change in the future.
#'
#' This function is experimental, its name and the details of its behavior are subject to change in future versions.
#'
#' @inherit split_cols_by return
#'
#' @seealso [top_left()]
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   split_rows_by("RACE") %>%
#'   append_topleft("Ethnicity") %>%
#'   analyze("AGE") %>%
#'   append_topleft("  Age")
#'
#' tbl <- build_table(lyt, DM2)
#' tbl
#'
#' @export
append_topleft <- function(lyt, newlines) {
  stopifnot(
    is(lyt, "PreDataTableLayouts"),
    is(newlines, "character")
  )
  lyt@top_left <- c(lyt@top_left, newlines)
  lyt
}

#' Create an `rtable` row
#'
#' @inheritParams compat_args
#' @param ... cell values.
#'
#' @return A row object of the context-appropriate type (label or data).
#'
#' @examples
#' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)")
#' rrow("")
#'
#' @family compatibility
#' @export
rrow <- function(row.name = "", ..., format = NULL, indent = 0, inset = 0L) {
  vals <- list(...)
  if (is.null(row.name)) {
    row.name <- ""
  } else if (!is(row.name, "character")) {
    stop("row.name must be NULL or a character string")
  }
  if (length(vals) == 0L) {
    LabelRow(
      lev = as.integer(indent),
      label = row.name,
      name = row.name,
      vis = TRUE,
      table_inset = 0L
    )
  } else {
    csps <- as.integer(sapply(vals, function(x) {
      attr(x, "colspan", exact = TRUE) %||% 1L
    }))
    ## we have to leave the formats on the cells and NOT the row unless we were
    ## already told to do so, because row formats get clobbered  when cbinding
    ## but cell formats do not.
    ## formats = sapply(vals, obj_format)
    ## if(is.character(formats) && length(unique(formats)) == 1L && is.null(format))
    ##     format = unique(formats)
    DataRow(
      vals = vals, lev = as.integer(indent), label = row.name,
      name = row.name, ## XXX TODO
      cspan = csps,
      format = format,
      table_inset = as.integer(inset)
    )
  }
}

#' Create an `rtable` row from a vector or list of values
#'
#' @inheritParams compat_args
#' @param ... values in vector/list form.
#'
#' @inherit rrow return
#'
#' @examples
#' rrowl("a", c(1, 2, 3), format = "xx")
#' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx")
#'
#'
#' rrowl("N", table(iris$Species))
#' rrowl("N", table(iris$Species), format = "xx")
#'
#' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE)
#'
#' rrow(row.name = "row 1", x)
#' rrow("ABC", 2, 3)
#'
#' rrowl(row.name = "row 1", c(1, 2), c(3, 4))
#' rrow(row.name = "row 2", c(1, 2), c(3, 4))
#'
#' @family compatibility
#' @export
rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L) {
  dots <- list(...)
  args_list <- c(list(
    row.name = row.name, format = format,
    indent = indent, inset = inset
  ), val = unlist(lapply(dots, as.list), recursive = FALSE))
  do.call(rrow, args_list)
}

## rcell moved to tt_afun_utils.R

## inefficient trash
paste_em_n <- function(lst, n, sep = ".") {
  ret <- lst[[1]]
  if (n > 1) {
    for (i in 2:n) {
      ret <- paste(ret, lst[[i]], sep = sep)
    }
  }
  ret
}

hrows_to_colinfo <- function(rows) {
  nr <- length(rows)
  stopifnot(nr > 0)
  cspans <- lapply(rows, row_cspans)
  vals <- lapply(rows, function(x) unlist(row_values(x)))
  unqvals <- lapply(vals, unique)
  formats <- lapply(rows, obj_format)
  counts <- NULL
  if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row
    counts <- vals[[nr]]
    vals <- vals[-nr]
    cspans <- cspans[-nr]
    nr <- nr - 1
  }
  ## easiest case, one header row no counts. we're done
  ## XXX could one row but cspan ever make sense????
  ## I don't think so?
  if (nr == 1) { ## && all(cspans == 1L)) {
    ret <- manual_cols(unlist(vals[[1]]))
    if (!is.null(counts)) {
      col_counts(ret) <- counts
      disp_ccounts(ret) <- TRUE
    }
    return(ret)
  }
  ## second easiest case full repeated nestin
  repvals <- mapply(function(v, csp) rep(v, times = csp),
    v = vals, csp = cspans, SIMPLIFY = FALSE
  )

  ## nr > 1 here
  fullnest <- TRUE
  for (i in 2:nr) {
    psted <- paste_em_n(repvals, i - 1)
    spl <- split(repvals[[i]], psted)
    if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) {
      fullnest <- FALSE
      break
    }
  }

  ## if its full nesting we're done, so put
  ## the counts on as necessary and return.
  if (fullnest) {
    ret <- manual_cols(.lst = unqvals)
    if (!is.null(counts)) {
      col_counts(ret) <- counts
      disp_ccounts(ret) <- TRUE
    }
    return(ret)
  }

  ## booo. the fully complex case where the multiple rows
  ## really don't represent nesting at all, each top level
  ## can have different sub labels

  ## we will build it up as if it were full nesting and then prune
  ## based on the columns we actually want.

  fullcolinfo <- manual_cols(.lst = unqvals)
  fullbusiness <- names(collect_leaves(coltree(fullcolinfo)))
  wanted <- paste_em_n(repvals, nr)
  wantcols <- match(wanted, fullbusiness)
  stopifnot(all(!is.na(wantcols)))

  subset_cols(fullcolinfo, wantcols)
}

#' Create a header
#'
#' @inheritParams compat_args
#' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()],
#'   [LabelRow()], etc.
#'
#' @return A `InstantiatedColumnInfo` object.
#'
#' @examples
#' h1 <- rheader(c("A", "B", "C"))
#' h1
#'
#' h2 <- rheader(
#'   rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)),
#'   rrow(NULL, "A", "B", "A", "B")
#' )
#' h2
#'
#' @family compatibility
#' @export
rheader <- function(..., format = "xx", .lst = NULL) {
  if (!is.null(.lst)) {
    args <- .lst
  } else {
    args <- list(...)
  }
  rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) {
    list(rrowl(row.name = NULL, val = args[[1]], format = format))
  } else if (are(args, "TableRow")) {
    args
  }

  hrows_to_colinfo(rrows)
}

.char_to_hrows <- function(hdr) {
  nlfnd <- grep("\n", hdr, fixed = TRUE)
  if (length(nlfnd) == 0) {
    return(list(rrowl(NULL, hdr)))
  }

  stopifnot(length(nlfnd) == length(hdr))
  raw <- strsplit(hdr, "\n", fixed = TRUE)
  lens <- unique(sapply(raw, length))
  stopifnot(length(lens) == 1L)
  lapply(
    seq(1, lens),
    function(i) {
      rrowl(NULL, vapply(raw, `[`, NA_character_, i = i))
    }
  )
}

#' Create a table
#'
#' @inheritParams compat_args
#' @inheritParams gen_args
#' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header
#'   (column structure) of the table. This can be as row objects (legacy), character vectors, or an
#'   `InstantiatedColumnInfo` object.
#' @param ... rows to place in the table.
#'
#' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`).
#'
#' @examples
#' rtable(
#'   header = LETTERS[1:3],
#'   rrow("one to three", 1, 2, 3),
#'   rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more")
#' )
#'
#' # Table with multirow header
#'
#' sel <- iris$Species == "setosa"
#' mtbl <- rtable(
#'   header = rheader(
#'     rrow(
#'       row.name = NULL, rcell("Sepal.Length", colspan = 2),
#'       rcell("Petal.Length", colspan = 2)
#'     ),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "All Species",
#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
#'     mean(iris$Petal.Length), median(iris$Petal.Length),
#'     format = "xx.xx"
#'   ),
#'   rrow(
#'     row.name = "Setosa",
#'     mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]),
#'     mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel])
#'   )
#' )
#'
#' mtbl
#'
#' names(mtbl) # always first row of header
#'
#' # Single row header
#'
#' tbl <- rtable(
#'   header = c("Treatement\nN=100", "Comparison\nN=300"),
#'   format = "xx (xx.xx%)",
#'   rrow("A", c(104, .2), c(100, .4)),
#'   rrow("B", c(23, .4), c(43, .5)),
#'   rrow(""),
#'   rrow("this is a very long section header"),
#'   rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
#'   rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
#' )
#' tbl
#'
#' row.names(tbl)
#' names(tbl)
#'
#' # Subsetting
#'
#' tbl[1, ]
#' tbl[, 1]
#'
#' tbl[1, 2]
#' tbl[2, 1]
#'
#' tbl[3, 2]
#' tbl[5, 1]
#' tbl[5, 2]
#'
#' # Data Structure methods
#'
#' dim(tbl)
#' nrow(tbl)
#' ncol(tbl)
#' names(tbl)
#'
#' # Colspans
#'
#' tbl2 <- rtable(
#'   c("A", "B", "C", "D", "E"),
#'   format = "xx",
#'   rrow("r1", 1, 2, 3, 4, 5),
#'   rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2))
#' )
#' tbl2
#'
#' @family compatibility
#' @export
rtable <- function(header, ..., format = NULL, hsep = default_hsep(),
                   inset = 0L) {
  if (is.character(header)) {
    header <- .char_to_hrows(header)
  } # list(rrowl(NULL, header))
  if (is.list(header)) {
    if (are(header, "TableRow")) {
      colinfo <- hrows_to_colinfo(header)
    } else if (are(header, "list")) {
      colinfo <- do.call(rheader, header)
    }
  } else if (is(header, "InstantiatedColumnInfo")) {
    colinfo <- header
  } else if (is(header, "TableRow")) {
    colinfo <- hrows_to_colinfo(list(header))
  } else {
    stop("problems")
  }

  body <- list(...)
  ## XXX this shouldn't be needed. hacky
  if (length(body) == 1 && is.list(body[[1]])) {
    body <- body[[1]]
  }
  if (are(body, "ElementaryTable") &&
    all(sapply(body, function(tb) {
      nrow(tb) == 1 && obj_name(tb) == ""
    }))) {
    body <- lapply(body, function(tb) tree_children(tb)[[1]])
  }

  TableTree(
    kids = body, format = format, cinfo = colinfo,
    labelrow = LabelRow(lev = 0L, label = "", vis = FALSE),
    hsep = hsep, inset = inset
  )
}

#' @rdname rtable
#' @export
rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) {
  dots <- list(...)
  args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply(
    dots,
    as.list
  ), recursive = FALSE))
  do.call(rtable, args_list)
}

# All object annotations are identical (and exist)
all_annots_identical <- function(all_annots) {
  if (!is.list(all_annots)) {
    all_annots[1] != "" && length(unique(all_annots)) == 1
  } else {
    length(all_annots[[1]]) > 0 && Reduce(identical, all_annots)
  }
}

# Only first object has annotations
only_first_annot <- function(all_annots) {
  if (!is.list(all_annots)) {
    all_annots[1] != "" && all(all_annots[-1] == "")
  } else {
    length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0)
  }
}

#' @param gap `r lifecycle::badge("deprecated")` ignored.
#' @param check_headers `r lifecycle::badge("deprecated")` ignored.
#'
#' @return A formal table object.
#'
#' @rdname rbind
#' @aliases rbind
#' @export
rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) {
  ## nocov start
  if (lifecycle::is_present(gap)) {
    lifecycle::deprecate_warn(
      when = "0.3.2",
      what = "rbindl_rtables(gap)"
    )
  }
  if (lifecycle::is_present(check_headers)) {
    lifecycle::deprecate_warn(
      when = "0.3.2",
      what = "rbindl_rtables(check_headers)"
    )
  }
  ## nocov end

  firstcols <- col_info(x[[1]])
  i <- 1
  while (no_colinfo(firstcols) && i <= length(x)) {
    firstcols <- col_info(x[[i]])
    i <- i + 1
  }

  lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi)))

  rbind_annot <- list(
    main_title = "",
    subtitles = character(),
    main_footer = character(),
    prov_footer = character()
  )

  # Titles/footer info are (independently) retained from first object if
  # identical or missing in all other objects
  all_titles <- sapply(x, main_title)
  if (all_annots_identical(all_titles) || only_first_annot(all_titles)) {
    rbind_annot[["main_title"]] <- all_titles[[1]]
  }

  all_sts <- lapply(x, subtitles)
  if (all_annots_identical(all_sts) || only_first_annot(all_sts)) {
    rbind_annot[["subtitles"]] <- all_sts[[1]]
  }

  all_ftrs <- lapply(x, main_footer)
  if (all_annots_identical(all_ftrs) || only_first_annot(all_ftrs)) {
    rbind_annot[["main_footer"]] <- all_ftrs[[1]]
  }

  all_pfs <- lapply(x, prov_footer)
  if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) {
    rbind_annot[["prov_footer"]] <- all_pfs[[1]]
  }

  ## if we got only ElementaryTable and
  ## TableRow objects, construct a new
  ## elementary table with all the rows
  ## instead of adding nesting.

  ## we used to check for xi not being a lable row, why?? XXX
  if (all(sapply(x, function(xi) {
    (is(xi, "ElementaryTable") && !labelrow_visible(xi)) ||
      is(xi, "TableRow")
  }))) { ## && !is(xi, "LabelRow")}))) {
    x <- unlist(lapply(x, function(xi) {
      if (is(xi, "TableRow")) {
        xi
      } else {
        lst <- tree_children(xi)
        lapply(lst, indent,
          by = indent_mod(xi)
        )
      }
    }))
  }

  TableTree(
    kids = x,
    cinfo = firstcols,
    name = "rbind_root",
    label = "",
    title = rbind_annot[["main_title"]],
    subtitles = rbind_annot[["subtitles"]],
    main_footer = rbind_annot[["main_footer"]],
    prov_footer = rbind_annot[["prov_footer"]]
  )
}

#' Row-bind `TableTree` and related objects
#'
#' @param deparse.level (`numeric(1)`)\cr currently ignored.
#' @param ... (`ANY`)\cr elements to be stacked.
#'
#' @note
#' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all
#' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed
#' and must be set for the bound table via the [formatters::main_title()], [formatters::subtitles()],
#' [formatters::main_footer()], and [formatters::prov_footer()] functions.
#'
#' @examples
#' mtbl <- rtable(
#'   header = rheader(
#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "All Species",
#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
#'     mean(iris$Petal.Length), median(iris$Petal.Length),
#'     format = "xx.xx"
#'   )
#' )
#'
#' mtbl2 <- with(subset(iris, Species == "setosa"), rtable(
#'   header = rheader(
#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "Setosa",
#'     mean(Sepal.Length), median(Sepal.Length),
#'     mean(Petal.Length), median(Petal.Length),
#'     format = "xx.xx"
#'   )
#' ))
#'
#' rbind(mtbl, mtbl2)
#' rbind(mtbl, rrow(), mtbl2)
#' rbind(mtbl, rrow("aaa"), indent(mtbl2))
#'
#' @exportMethod rbind
#' @rdname rbind
setMethod(
  "rbind", "VTableNodeInfo",
  function(..., deparse.level = 1) {
    rbindl_rtables(list(...))
  }
)

#' @param y (`ANY`)\cr second element to be row-bound via `rbind2`.
#'
#' @exportMethod rbind2
#' @rdname int_methods
setMethod(
  "rbind2", c("VTableNodeInfo", "missing"),
  function(x, y) {
    TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "")
  }
)

#' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.
#' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.
#'
#' @exportMethod rbind2
#' @rdname rbind
setMethod(
  "rbind2", "VTableNodeInfo",
  function(x, y) {
    rbindl_rtables(list(x, y))
  }
)

EmptyTreePos <- TreePos()

## this is painful to do right but we were doing it wrong
## before and it now matters because count display information
## is in the tree which means all points in the structure
## must be pathable, which they aren't if siblings have
## identical names
fix_col_nm_recursive <- function(ct, newname, rename_obj = TRUE, oldnm) {
  if (rename_obj) {
    obj_name(ct) <- newname
  }
  if (is(ct, "LayoutColTree")) {
    kids <- tree_children(ct)
    kidnms <- names(kids)
    newkids <- lapply(kids, fix_col_nm_recursive,
      newname = newname,
      rename_obj = FALSE,
      oldnm = oldnm
    )
    names(newkids) <- kidnms
    tree_children(ct) <- newkids
  }
  mypos <- tree_pos(ct)
  if (!identical(mypos, EmptyTreePos)) {
    spls <- pos_splits(mypos)
    firstspl <- spls[[1]]
    if (obj_name(firstspl) == oldnm) {
      obj_name(firstspl) <- newname
      spls[[1]] <- firstspl
      pos_splits(mypos) <- spls
      tree_pos(ct) <- mypos
    }
  }
  if (!rename_obj) {
    spls <- pos_splits(mypos)
    splvals <- pos_splvals(mypos)
    pos_splits(mypos) <- c(
      list(AllSplit(split_name = newname)),
      spls
    )
    pos_splvals(mypos) <- c(
      list(SplitValue(NA_character_,
        sub_expr = quote(TRUE)
      )),
      splvals
    )
    tree_pos(ct) <- mypos
  }
  ct
}

fix_nms <- function(ct) {
  if (is(ct, "LayoutColLeaf")) {
    return(ct)
  }
  kids <- lapply(tree_children(ct), fix_nms)
  names(kids) <- vapply(kids, obj_name, "")
  tree_children(ct) <- kids
  ct
}

make_cbind_names <- function(num, tokens) {
  cbind_tokens <- grep("^(new_)*cbind_tbl", tokens, value = TRUE)
  ret <- paste0("cbind_tbl_", seq_len(num))
  if (length(cbind_tokens) == 0) {
    return(ret)
  }
  oldprefixes <- gsub("cbind_tbl.*", "", cbind_tokens)
  oldprefix <- oldprefixes[which.max(nchar(oldprefixes))]
  paste0("new_", oldprefix, ret)
}

combine_cinfo <- function(..., new_total = NULL, sync_count_vis) {
  tabs <- list(...)
  chk_cbindable_many(tabs)
  cinfs <- lapply(tabs, col_info)
  stopifnot(are(cinfs, "InstantiatedColumnInfo"))

  ctrees <- lapply(cinfs, coltree)
  oldnms <- nms <- vapply(ctrees, obj_name, "")
  path_els <- unique(unlist(lapply(ctrees, col_paths), recursive = TRUE))
  nms <- make_cbind_names(num = length(oldnms), tokens = path_els)

  ctrees <- mapply(function(ct, nm, oldnm) {
    ct <- fix_col_nm_recursive(ct, nm, rename_obj = TRUE, oldnm = "") # oldnm)
    ct
  }, ct = ctrees, nm = nms, oldnm = oldnms, SIMPLIFY = FALSE)
  names(ctrees) <- nms

  newctree <- LayoutColTree(kids = ctrees, colcount = NA_integer_, name = "cbind_root")
  newctree <- fix_nms(newctree)
  newcounts <- unlist(lapply(cinfs, col_counts))
  if (is.null(new_total)) {
    new_total <- sum(newcounts)
  }
  newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE)
  newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts))
  if (!sync_count_vis) {
    newdisp <- NA
  } else {
    newdisp <- any(vapply(cinfs, disp_ccounts, NA))
  }
  alltls <- lapply(cinfs, top_left)
  newtl <- character()
  if (!are(tabs, "TableRow")) {
    alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same
    if (length(alltls) > 0) {
      newtl <- alltls[[1]]
    }
  }
  InstantiatedColumnInfo(
    treelyt = newctree,
    csubs = newexprs,
    extras = newexargs,
    cnts = newcounts,
    dispcounts = newdisp,
    countformat = colcount_format(cinfs[[1]]),
    total_cnt = new_total,
    topleft = newtl
  )
}

nz_len_els <- function(lst) {
  if (is(lst, "list")) {
    lst[vapply(lst, function(x) length(x) > 0, NA)]
  } else if (is(lst, "character")) {
    lst[nzchar(lst)]
  } else {
    lst
  }
}

has_one_unq <- function(x) {
  length(unique(nz_len_els(x))) <= 1
}

classvec <- function(lst, enforce_one = TRUE) {
  if (enforce_one) {
    vapply(lst, class, "")
  } else {
    lapply(lst, class)
  }
}

chk_cbindable_many <- function(lst) {
  ## we actually want is/inherits there but no easy way
  ## to figure out what the lowest base class is
  ## that I can think of right now, so we do the
  ## broken wrong thing instead :(
  if (are(lst, "TableRow")) {
    if (!has_one_unq(classvec(lst))) {
      stop("Cannot cbind different types of TableRow objects together")
    }
    return(TRUE)
  }
  ## if(!are(lst, "VTableTree")
  ##     stop("Not all elements to be bound are TableTrees or TableRows")

  nrs <- vapply(lst, NROW, 1L)
  if (!has_one_unq(nrs)) {
    stop("Not all elements to be bound have matching numbers of rows")
  }

  tls <- lapply(lst, top_left)
  if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) {
    stop(
      "Elements to be bound have differing top-left content: ",
      paste(which(!duplicated(tls)), collapse = " ")
    )
  }

  if (all(vapply(lst, function(x) nrow(x) == 0, NA))) {
    return(TRUE)
  }

  rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])),
    nrow = nrs[[1]]
  )
  rnsok <- apply(rns, 1, has_one_unq)
  if (!all(rnsok)) {
    stop(
      "Mismatching, non-empty row names detected in rows ",
      paste(which(!rnsok), collapse = " ")
    )
  }

  rws <- lapply(lst, collect_leaves, add.labrows = TRUE)
  rwclsmat <- matrix(unlist(lapply(rws, classvec)),
    ncol = length(lst)
  )

  rwsok <- apply(rwclsmat, 1, has_one_unq)
  if (!all(rwsok)) {
    stop(
      "Mismatching row classes found for rows: ",
      paste(which(!rwsok), collapse = " ")
    )
  }
  TRUE
}

#' Column-bind two `TableTree` objects
#'
#' @param x (`TableTree` or `TableRow`)\cr a table or row object.
#' @param ... one or more further objects of the same class as `x`.
#' @param sync_count_vis (`logical(1)`)\cr should column count
#'   visibility be synced across the new and existing columns.
#'   Currently defaults to `TRUE` for backwards compatibility but
#'   this may change in future releases.
#'
#' @inherit rbindl_rtables return
#'
#' @examples
#' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4))
#' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6))
#' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10))
#'
#' t1 <- cbind_rtables(x, y)
#' t1
#'
#' t2 <- cbind_rtables(x, y, z)
#' t2
#'
#' col_paths_summary(t1)
#' col_paths_summary(t2)
#'
#' @export
cbind_rtables <- function(x, ..., sync_count_vis = TRUE) {
  lst <- list(...)
  newcinfo <- combine_cinfo(x, ..., sync_count_vis = sync_count_vis)
  recurse_cbindl(x, cinfo = newcinfo, .list = lst)
}

setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl"))

setMethod(
  "recurse_cbindl", c(
    x = "VTableNodeInfo",
    cinfo = "NULL"
  ),
  function(x, cinfo, .list = NULL) {
    recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list)
  }
)

setMethod(
  "recurse_cbindl", c(
    x = "TableTree",
    cinfo = "InstantiatedColumnInfo"
  ),
  function(x, cinfo, .list = NULL) {
    stopifnot(are(.list, "VTableTree"))
    ## chk_cbindable(x, y)
    xcont <- content_table(x)
    lstconts <- lapply(.list, content_table)
    lcontnrows <- vapply(lstconts, NROW, 1L)
    unqnrcont <- unique(c(NROW(xcont), lcontnrows))
    if (length(unqnrcont) > 1) {
      stop(
        "Got differing numbers of content rows [",
        paste(unqnrcont, collapse = ", "),
        "]. Unable to cbind these rtables"
      )
    }

    if (unqnrcont == 0) {
      cont <- ElementaryTable(cinfo = cinfo)
    } else {
      cont <- recurse_cbindl(xcont,
        .list = lstconts,
        cinfo = cinfo
      )
    }

    kids <- lapply(
      seq_along(tree_children(x)),
      function(i) {
        recurse_cbindl(
          x = tree_children(x)[[i]],
          cinfo = cinfo,
          .list = lapply(.list, function(tt) tree_children(tt)[[i]])
        )
      }
    )
    names(kids) <- names(tree_children(x))
    TableTree(
      kids = kids, labelrow = recurse_cbindl(tt_labelrow(x),
        cinfo = cinfo,
        .list = lapply(.list, tt_labelrow)
      ),
      cont = cont,
      name = obj_name(x),
      lev = tt_level(x),
      cinfo = cinfo,
      format = obj_format(x)
    )
  }
)

setMethod(
  "recurse_cbindl", c(
    x = "ElementaryTable",
    cinfo = "InstantiatedColumnInfo"
  ),
  function(x, cinfo, .list) {
    stopifnot(are(.list, class(x)))
    ##   chk_cbindable(x,y)
    if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) {
      col_info(x) <- cinfo
      return(x) ## this needs testing... I was right, it did #136
    }
    kids <- lapply(
      seq_along(tree_children(x)),
      function(i) {
        recurse_cbindl(
          x = tree_children(x)[[i]],
          cinfo = cinfo,
          .list = lapply(.list, function(tt) tree_children(tt)[[i]])
        )
      }
    )
    names(kids) <- names(tree_children(x))

    ElementaryTable(
      kids = kids,
      labelrow = recurse_cbindl(tt_labelrow(x),
        .list = lapply(.list, tt_labelrow),
        cinfo
      ),
      name = obj_name(x),
      lev = tt_level(x),
      cinfo = cinfo,
      format = obj_format(x),
      var = obj_avar(x)
    )
  }
)

.combine_rows <- function(x, cinfo = NULL, .list) {
  stopifnot(are(.list, class(x)))

  avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE))
  avars <- avars[!is.na(avars)]

  if (length(unique(avars)) > 1) {
    stop("Got rows that don't analyze the same variable")
  }

  xlst <- c(list(x), .list)

  ncols <- vapply(xlst, ncol, 1L)
  totcols <- sum(ncols)
  cumncols <- cumsum(ncols)
  strtncols <- c(0L, head(cumncols, -1)) + 1L
  vals <- vector("list", totcols)
  cspans <- integer(totcols)
  ## vals[1:ncol(x)] <- row_values(x)
  ## cpans[1:ncol(x)] <- row_cspans(x)

  for (i in seq_along(xlst)) {
    strt <- strtncols[i]
    end <- cumncols[i]
    ## full vars are here for debugging purposes
    fullvy <- vy <- row_cells(xlst[[i]]) # nolint
    fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint

    if (
      i > 1 &&
        identical(rawvalues(vy[[1]]), rawvalues(lastval)) &&
        ##  cspy[1] == lastspn &&
        lastspn > 1
    ) {
      vy <- vy[-1]
      cspans[strt - 1L] <- lastspn + cspy[1]
      cspy <- cspy[-1]
      strt <- strt + 1L
    }
    if (length(vy) > 0) {
      vals[strt:end] <- vy
      cspans[strt:end] <- cspy
      lastval <- vy[[length(vy)]]
      lastspn <- cspy[[length(cspy)]]
    } else {
      ## lastval stays the same
      lastspn <- cspans[strtncols[i] - 1] ## already updated
    }
  }

  ## Could be DataRow or ContentRow
  ## This is ok because LabelRow is special cased
  constr_fun <- get(class(x), mode = "function")
  constr_fun(
    vals = vals,
    cspan = cspans,
    cinfo = cinfo,
    var = obj_avar(x),
    format = obj_format(x),
    name = obj_name(x),
    label = obj_label(x)
  )
}

setMethod(
  "recurse_cbindl", c(
    "TableRow",
    "InstantiatedColumnInfo"
  ),
  function(x, cinfo = NULL, .list) {
    .combine_rows(x, cinfo, .list)
  }
)

setMethod(
  "recurse_cbindl", c(
    x = "LabelRow",
    cinfo = "InstantiatedColumnInfo"
  ),
  function(x, cinfo = NULL, .list) {
    col_info(x) <- cinfo
    x
  }
)

## we don't care about the following discrepencies:
## - ci2  having NA counts when ci1 doesn't
## - mismatching display_ccounts values
## - mismatching colcount formats
##

# chk_compat_cinfos <- function(ci1, ci2) {
chk_compat_cinfos <- function(tt1, tt2) {
  nc1 <- ncol(tt1)
  nc2 <- ncol(tt2)
  if (nc1 != nc2 && nc1 > 0 && nc2 > 0) {
    stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2)
  }
  if (no_colinfo(tt1) || no_colinfo(tt2)) {
    return(TRUE)
  }
  ci1 <- col_info(tt1)
  ci2 <- col_info(tt2)
  ## this will enforce same length and
  ## same names, in addition to same
  ## expressions so we dont need
  ## to check those separateley
  if (!identical(col_exprs(ci1), col_exprs(ci2))) {
    stop("Column structures not compatible: subset expression lists not identical")
  }

  if (any(!is.na(col_counts(ci2))) &&
    !identical(
      col_counts(ci1),
      col_counts(ci2)
    )) {
    stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts")
  }

  if (any(sapply(
    col_extra_args(ci2),
    function(x) length(x) > 0
  )) &&
    !identical(
      col_extra_args(ci1),
      col_extra_args(ci2)
    )) {
    stop(
      "Column structures not compatible: 2nd column structure has ",
      "non-matching, non-null extra args"
    )
  }

  if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) {
    stop(
      "Top-left materials not compatible: Got non-empty, non-matching ",
      "top-left materials. Clear them using top_left(x)<-character() ",
      "before binding to force compatibility."
    )
  }
  TRUE
}


#' Insert `rrow`s at (before) a specific location
#'
#' `r lifecycle::badge("deprecated")`
#'
#' This function is deprecated and will be removed in a future release of `rtables`. Please use
#' [insert_row_at_path()] or [label_at_path()] instead.
#'
#' @param tbl (`VTableTree`)\cr a `rtable` object.
#' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`.
#' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1).
#' @param ascontent (`flag`)\cr currently ignored.
#'
#' @return A `TableTree` of the same specific class as `tbl`.
#'
#' @note
#' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do
#' not already contain a label row when there is a non-trivial nested row structure in `tbl`.
#'
#' @examples
#' o <- options(warn = 0)
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   analyze("Sepal.Length")
#'
#' tbl <- build_table(lyt, iris)
#'
#' insert_rrow(tbl, rrow("Hello World"))
#' insert_rrow(tbl, rrow("Hello World"), at = 2)
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_rows_by("Species") %>%
#'   analyze("Sepal.Length")
#'
#' tbl2 <- build_table(lyt2, iris)
#'
#' insert_rrow(tbl2, rrow("Hello World"))
#' insert_rrow(tbl2, rrow("Hello World"), at = 2)
#' insert_rrow(tbl2, rrow("Hello World"), at = 4)
#'
#' insert_rrow(tbl2, rrow("new row", 5, 6, 7))
#'
#' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3)
#'
#' options(o)
#'
#' @export
insert_rrow <- function(tbl, rrow, at = 1,
                        ascontent = FALSE) {
  lifecycle::deprecate_warn(
    when = "0.4.0",
    what = "insert_rrow()",
    with = I("insert_row_at_path() or label_at_path()")
  )
  stopifnot(
    is(tbl, "VTableTree"),
    is(rrow, "TableRow"),
    at >= 1 && at <= nrow(tbl) + 1
  )
  chk_compat_cinfos(tbl, rrow)
  if (no_colinfo(rrow)) {
    col_info(rrow) <- col_info(tbl)
  }

  if (at == 1) {
    return(rbindl_rtables(list(rrow, tbl)))
  } else if (at == nrow(tbl) + 1) {
    return(rbind2(tbl, rrow))
  }

  ret <- recurse_insert(tbl, rrow,
    at = at,
    pos = 0,
    ascontent = ascontent
  )
  ret
}

.insert_helper <- function(tt, row, at, pos,
                           ascontent = FALSE) {
  islab <- is(row, "LabelRow")
  kids <- tree_children(tt)
  numkids <- length(kids)
  kidnrs <- sapply(kids, nrow)
  cumpos <- pos + cumsum(kidnrs)
  contnr <- if (is(tt, "TableTree")) {
    nrow(content_table(tt))
  } else {
    0
  }
  contnr <- contnr + as.numeric(labelrow_visible(tt))

  totnr <- nrow(tt)
  endpos <- pos + totnr
  atend <- !islab && endpos == at - 1
  if (at == pos + 1 && islab) {
    if (labelrow_visible(tt)) {
      stop("Inserting a label row at a position that already has a label row is not currently supported")
    }
    tt_labelrow(tt) <- row
    return(tt)
  }

  if (numkids == 0) {
    kids <- list(row)
  } else if (atend) {
    if (are(kids, "TableRow")) {
      kids <- c(kids, list(row))
    } else {
      kids[[numkids]] <- recurse_insert(
        kids[[numkids]],
        row = row,
        at = at,
        pos = pos + contnr + sum(kidnrs[-numkids]),
        ascontent = ascontent
      )
    }
  } else { # have >0 kids
    kidnrs <- sapply(kids, nrow)
    cumpos <- pos + cumsum(kidnrs)

    ## data rows go in the end of the
    ## preceding subtable (if applicable)
    ## label rows go in the beginning of
    ##  one at at
    ind <- min(
      which((cumpos + !islab) >= at),
      numkids
    )
    thekid <- kids[[ind]]

    if (is(thekid, "TableRow")) {
      tt_level(row) <- tt_level(thekid)
      if (ind == 1) {
        bef <- integer()
        aft <- 1:numkids
      } else if (ind == numkids) {
        bef <- 1:(ind - 1)
        aft <- ind
      } else {
        bef <- 1:ind
        aft <- (ind + 1):numkids
      }
      kids <- c(
        kids[bef], list(row),
        kids[aft]
      )
    } else { # kid is not a table row
      newpos <- if (ind == 1) {
        pos + contnr
      } else {
        cumpos[ind - 1]
      }

      kids[[ind]] <- recurse_insert(thekid,
        row,
        at,
        pos = newpos,
        ascontent = ascontent
      )
    } # end kid is not table row
  }
  tree_children(tt) <- kids
  tt
}

setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert"))

setMethod(
  "recurse_insert", "TableTree",
  function(tt, row, at, pos, ascontent = FALSE) {
    ctab <- content_table(tt)
    contnr <- nrow(ctab)
    contpos <- pos + contnr
    islab <- is(row, "LabelRow")
    ## this will NOT insert it as
    if ((contnr > 0 || islab) && contpos > at) {
      content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE)
      return(tt)
    }

    .insert_helper(tt, row,
      at = at, pos = pos + contnr,
      ascontent = ascontent
    )
  }
)

setMethod(
  "recurse_insert", "ElementaryTable",
  function(tt, row, at, pos, ascontent = FALSE) {
    .insert_helper(tt, row,
      at = at, pos = pos,
      ascontent = FALSE
    )
  }
)

#' Internal generics and methods
#'
#' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no
#' attention to this documentation.
#'
#' @param x (`ANY`)\cr the object.
#' @param obj (`ANY`)\cr the object.
#'
#' @name internal_methods
#' @rdname int_methods
#' @aliases int_methods
NULL

#' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object.
#'
#' @rdname dimensions
#' @exportMethod nrow
setMethod(
  "nrow", "VTableTree",
  function(x) length(collect_leaves(x, TRUE, TRUE))
)

#' @rdname int_methods
#' @exportMethod nrow
setMethod(
  "nrow", "TableRow",
  function(x) 1L
)

#' Table dimensions
#'
#' @param x (`TableTree` or `ElementaryTable`)\cr a table object.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("SEX", "AGE"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' dim(tbl)
#' nrow(tbl)
#' ncol(tbl)
#'
#' NROW(tbl)
#' NCOL(tbl)
#'
#' @rdname dimensions
#' @exportMethod ncol
setMethod(
  "ncol", "VTableNodeInfo",
  function(x) {
    ncol(col_info(x))
  }
)

#' @rdname int_methods
#' @exportMethod ncol
setMethod(
  "ncol", "TableRow",
  function(x) {
    if (!no_colinfo(x)) {
      ncol(col_info(x))
    } else {
      length(spanned_values(x))
    }
  }
)

#' @rdname int_methods
#' @exportMethod ncol
setMethod(
  "ncol", "LabelRow",
  function(x) {
    ncol(col_info(x))
  }
)

#' @rdname int_methods
#' @exportMethod ncol
setMethod(
  "ncol", "InstantiatedColumnInfo",
  function(x) {
    length(col_exprs(x))
  }
)

#' @rdname dimensions
#' @exportMethod dim
setMethod(
  "dim", "VTableNodeInfo",
  function(x) c(nrow(x), ncol(x))
)

#' Retrieve or set the direct children of a tree-style object
#'
#' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure.
#' @param value (`list`)\cr new list of children.
#'
#' @return A list of direct children of `x`.
#'
#' @export
#' @rdname tree_children
setGeneric("tree_children", function(x) standardGeneric("tree_children"))

#' @exportMethod tree_children
#' @rdname int_methods
setMethod(
  "tree_children", c(x = "VTree"),
  function(x) x@children
)

#' @exportMethod tree_children
#' @rdname int_methods
setMethod(
  "tree_children", c(x = "VTableTree"),
  function(x) x@children
)

## this includes VLeaf but also allows for general methods
## needed for table_inset being carried around by rows and
## such.
#' @exportMethod tree_children
#' @rdname int_methods
setMethod(
  "tree_children", c(x = "ANY"), ## "VLeaf"),
  function(x) list()
)

#' @export
#' @rdname tree_children
setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-"))

#' @exportMethod tree_children<-
#' @rdname int_methods
setMethod(
  "tree_children<-", c(x = "VTree"),
  function(x, value) {
    x@children <- value
    x
  }
)

#' @exportMethod tree_children<-
#' @rdname int_methods
setMethod(
  "tree_children<-", c(x = "VTableTree"),
  function(x, value) {
    x@children <- value
    x
  }
)

#' Retrieve or set content table from a `TableTree`
#'
#' Returns the content table of `obj` if it is a `TableTree` object, or `NULL` otherwise.
#'
#' @param obj (`TableTree`)\cr the table object.
#'
#' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not
#'   a formal table object).
#'
#' @export
#' @rdname content_table
setGeneric("content_table", function(obj) standardGeneric("content_table"))

#' @exportMethod content_table
#' @rdname int_methods
setMethod(
  "content_table", "TableTree",
  function(obj) obj@content
)

#' @exportMethod content_table
#' @rdname int_methods
setMethod(
  "content_table", "ANY",
  function(obj) NULL
)

#' @param value (`ElementaryTable`)\cr the new content table for `obj`.
#'
#' @export
#' @rdname content_table
setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-"))

#' @exportMethod "content_table<-"
#' @rdname int_methods
setMethod(
  "content_table<-", c("TableTree", "ElementaryTable"),
  function(obj, value) {
    obj@content <- value
    obj
  }
)

#' @param for_analyze (`flag`) whether split is an analyze split.
#' @rdname int_methods
setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos"))

#' @rdname int_methods
setMethod(
  "next_rpos", "PreDataTableLayouts",
  function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze)
)

.check_if_nest <- function(obj, nested, for_analyze) {
  if (!nested) {
    FALSE
  } else {
    ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?)
    for_analyze ||
      ## If its not an analyze split it can't go under an analyze split
      !(is(last_rowsplit(obj), "VAnalyzeSplit") ||
        is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint
  }
}

#' @rdname int_methods
setMethod(
  "next_rpos", "PreDataRowLayout",
  function(obj, nested, for_analyze) {
    l <- length(obj)
    if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) {
      l <- l + 1L
    }
    l
  }
)

#' @rdname int_methods
setMethod("next_rpos", "ANY", function(obj, nested) 1L)

#' @rdname int_methods
setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos"))

#' @rdname int_methods
setMethod(
  "next_cpos", "PreDataTableLayouts",
  function(obj, nested) next_cpos(clayout(obj), nested)
)

#' @rdname int_methods
setMethod(
  "next_cpos", "PreDataColLayout",
  function(obj, nested) {
    if (nested || length(obj[[length(obj)]]) == 0) {
      length(obj)
    } else {
      length(obj) + 1L
    }
  }
)

#' @rdname int_methods
setMethod("next_cpos", "ANY", function(obj, nested) 1L)

#' @rdname int_methods
setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit"))

#' @rdname int_methods
setMethod(
  "last_rowsplit", "NULL",
  function(obj) NULL
)

#' @rdname int_methods
setMethod(
  "last_rowsplit", "SplitVector",
  function(obj) {
    if (length(obj) == 0) {
      NULL
    } else {
      obj[[length(obj)]]
    }
  }
)

#' @rdname int_methods
setMethod(
  "last_rowsplit", "PreDataRowLayout",
  function(obj) {
    if (length(obj) == 0) {
      NULL
    } else {
      last_rowsplit(obj[[length(obj)]])
    }
  }
)

#' @rdname int_methods
setMethod(
  "last_rowsplit", "PreDataTableLayouts",
  function(obj) last_rowsplit(rlayout(obj))
)

# rlayout ----
## TODO maybe export these?

#' @rdname int_methods
setGeneric("rlayout", function(obj) standardGeneric("rlayout"))

#' @rdname int_methods
setMethod(
  "rlayout", "PreDataTableLayouts",
  function(obj) obj@row_layout
)

#' @rdname int_methods
setMethod("rlayout", "ANY", function(obj) PreDataRowLayout())

#' @rdname int_methods
setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-"))

#' @rdname int_methods
setMethod(
  "rlayout<-", "PreDataTableLayouts",
  function(object, value) {
    object@row_layout <- value
    object
  }
)

#' @rdname int_methods
setGeneric("tree_pos", function(obj) standardGeneric("tree_pos"))

## setMethod("tree_pos", "VNodeInfo",
##           function(obj) obj@pos_in_tree)

#' @rdname int_methods
setMethod(
  "tree_pos", "VLayoutNode",
  function(obj) obj@pos_in_tree
)

#' @rdname int_methods
setGeneric("pos_subset", function(obj) standardGeneric("pos_subset"))

#' @rdname int_methods
setMethod(
  "pos_subset", "TreePos",
  function(obj) obj@subset
)

#' @rdname int_methods
setGeneric("tree_pos<-", function(obj, value) standardGeneric("tree_pos<-"))

#' @rdname int_methods
setMethod(
  "tree_pos<-", "VLayoutNode",
  function(obj, value) {
    obj@pos_in_tree <- value
    obj
  }
)

## setMethod("pos_subset", "VNodeInfo",
##           function(obj) pos_subset(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_subset", "VLayoutNode",
  function(obj) pos_subset(tree_pos(obj))
)

#' @rdname int_methods
setGeneric("pos_splits", function(obj) standardGeneric("pos_splits"))

#' @rdname int_methods
setMethod(
  "pos_splits", "TreePos",
  function(obj) obj@splits
)

## setMethod("pos_splits", "VNodeInfo",
##           function(obj) pos_splits(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_splits", "VLayoutNode",
  function(obj) pos_splits(tree_pos(obj))
)

#' @rdname int_methods
setGeneric("pos_splits<-", function(obj, value) standardGeneric("pos_splits<-"))

#' @rdname int_methods
setMethod(
  "pos_splits<-", "TreePos",
  function(obj, value) {
    obj@splits <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "pos_splits<-", "VLayoutNode",
  function(obj, value) {
    pos <- tree_pos(obj)
    pos_splits(pos) <- value
    tree_pos(obj) <- pos
    obj
    obj
  }
)




#' @rdname int_methods
setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals"))

#' @rdname int_methods
setMethod(
  "pos_splvals", "TreePos",
  function(obj) obj@s_values
)

## setMethod("pos_splvals", "VNodeInfo",
##           function(obj) pos_splvals(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_splvals", "VLayoutNode",
  function(obj) pos_splvals(tree_pos(obj))
)

#' @rdname int_methods
setGeneric("pos_splvals<-", function(obj, value) standardGeneric("pos_splvals<-"))

#' @rdname int_methods
setMethod(
  "pos_splvals<-", "TreePos",
  function(obj, value) {
    obj@s_values <- value
    obj
  }
)

## setMethod("pos_splvals", "VNodeInfo",
##           function(obj) pos_splvals(tree_pos(obj)))

#' @rdname int_methods
setMethod(
  "pos_splvals<-", "VLayoutNode",
  function(obj, value) {
    pos <- tree_pos(obj)
    pos_splvals(pos) <- value
    tree_pos(obj) <- pos
    obj
  }
)


#' @rdname int_methods
setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels"))

#' @rdname int_methods
setMethod(
  "pos_splval_labels", "TreePos",
  function(obj) obj@sval_labels
)
## no longer used

## setMethod("pos_splval_labels", "VNodeInfo",
##            function(obj) pos_splval_labels(tree_pos(obj)))
## #' @rdname int_methods
## setMethod("pos_splval_labels", "VLayoutNode",
##            function(obj) pos_splval_labels(tree_pos(obj)))

#' @rdname int_methods
setGeneric("spl_payload", function(obj) standardGeneric("spl_payload"))

#' @rdname int_methods
setMethod("spl_payload", "Split", function(obj) obj@payload)

#' @rdname int_methods
setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-"))

#' @rdname int_methods
setMethod("spl_payload<-", "Split", function(obj, value) {
  obj@payload <- value
  obj
})

#' @rdname int_methods
setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var"))

#' @rdname int_methods
setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var)

## TODO revisit. do we want to do this? used in vars_in_layout, but only
## for convenience.
#' @rdname int_methods
setMethod("spl_label_var", "Split", function(obj) NULL)

### name related things
# #' @inherit formatters::formatter_methods
#' Methods for generics in the `formatters` package
#'
#' See the `formatters` documentation for descriptions of these generics.
#'
#' @inheritParams gen_args
#'
#' @return
#' * Accessor functions return the current value of the component being accessed of `obj`
#' * Setter functions return a modified copy of `obj` with the new value.
#'
#' @rdname formatters_methods
#' @aliases formatters_methods
#' @exportMethod obj_name
setMethod(
  "obj_name", "VNodeInfo",
  function(obj) obj@name
)

#' @rdname formatters_methods
#' @exportMethod obj_name
setMethod(
  "obj_name", "Split",
  function(obj) obj@name
)

#' @rdname formatters_methods
#' @exportMethod obj_name<-
setMethod(
  "obj_name<-", "VNodeInfo",
  function(obj, value) {
    obj@name <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_name<-
setMethod(
  "obj_name<-", "Split",
  function(obj, value) {
    obj@name <- value
    obj
  }
)

### Label related things
#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod("obj_label", "Split", function(obj) obj@split_label)

#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod("obj_label", "TableRow", function(obj) obj@label)

## XXX Do we want a convenience for VTableTree that
## grabs the label from the LabelRow or will
## that just muddy the waters?
#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod(
  "obj_label", "VTableTree",
  function(obj) obj_label(tt_labelrow(obj))
)

#' @rdname formatters_methods
#' @exportMethod obj_label
setMethod("obj_label", "ValueWrapper", function(obj) obj@label)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "Split",
  function(obj, value) {
    obj@split_label <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "TableRow",
  function(obj, value) {
    obj@label <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "ValueWrapper",
  function(obj, value) {
    obj@label <- value
    obj
  }
)

#' @rdname formatters_methods
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "VTableTree",
  function(obj, value) {
    lr <- tt_labelrow(obj)
    obj_label(lr) <- value
    if (!is.na(value) && nzchar(value)) {
      labelrow_visible(lr) <- TRUE
    } else if (is.na(value)) {
      labelrow_visible(lr) <- FALSE
    }
    tt_labelrow(obj) <- lr
    obj
  }
)

### Label rows.
#' @rdname int_methods
setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow"))

#' @rdname int_methods
setMethod(
  "tt_labelrow", "VTableTree",
  function(obj) obj@labelrow
)

#' @rdname int_methods
setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-"))

#' @rdname int_methods
setMethod(
  "tt_labelrow<-", c("VTableTree", "LabelRow"),
  function(obj, value) {
    if (no_colinfo(value)) {
      col_info(value) <- col_info(obj)
    }
    obj@labelrow <- value
    obj
  }
)

#' @rdname int_methods
setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible"))

#' @rdname int_methods
setMethod(
  "labelrow_visible", "VTableTree",
  function(obj) {
    labelrow_visible(tt_labelrow(obj))
  }
)

#' @rdname int_methods
setMethod(
  "labelrow_visible", "LabelRow",
  function(obj) obj@visible
)

#' @rdname int_methods
setMethod(
  "labelrow_visible", "VAnalyzeSplit",
  function(obj) .labelkids_helper(obj@var_label_position)
)

#' @rdname int_methods
setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-"))

#' @rdname int_methods
setMethod(
  "labelrow_visible<-", "VTableTree",
  function(obj, value) {
    lr <- tt_labelrow(obj)
    labelrow_visible(lr) <- value
    tt_labelrow(obj) <- lr
    obj
  }
)

#' @rdname int_methods
setMethod(
  "labelrow_visible<-", "LabelRow",
  function(obj, value) {
    obj@visible <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "labelrow_visible<-", "VAnalyzeSplit",
  function(obj, value) {
    obj@var_label_position <- value
    obj
  }
)

## TRUE is always, FALSE is never, NA is only when no
## content function (or rows in an instantiated table) is present
#' @rdname int_methods
setGeneric("label_kids", function(spl) standardGeneric("label_kids"))

#' @rdname int_methods
setMethod("label_kids", "Split", function(spl) spl@label_children)

#' @rdname int_methods
setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-"))

#' @rdname int_methods
setMethod("label_kids<-", c("Split", "character"), function(spl, value) {
  label_kids(spl) <- .labelkids_helper(value)
  spl
})

#' @rdname int_methods
setMethod("label_kids<-", c("Split", "logical"), function(spl, value) {
  spl@label_children <- value
  spl
})

#' @rdname int_methods
setGeneric("vis_label", function(spl) standardGeneric("vis_label"))

#' @rdname int_methods
setMethod("vis_label", "Split", function(spl) {
  .labelkids_helper(label_position(spl))
})

## #' @rdname int_methods
## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-"))
## #' @rdname int_methods
## setMethod("vis_label<-", "Split", function(spl, value) {
##     stop("defunct")
##     if(is.na(value))
##         stop("split label visibility must be TRUE or FALSE, got NA")
## #    spl@split_label_visible <- value
##     spl
## })

#' @rdname int_methods
setGeneric("label_position", function(spl) standardGeneric("label_position"))

#' @rdname int_methods
setMethod("label_position", "Split", function(spl) spl@split_label_position)

#' @rdname int_methods
setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position)

#' @rdname int_methods
setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-"))

#' @rdname int_methods
setMethod("label_position<-", "Split", function(spl, value) {
  value <- match.arg(value, valid_lbl_pos)
  spl@split_label_position <- value
  spl
})

### Function accessors (summary, tabulation and split) ----

#' @rdname int_methods
setGeneric("content_fun", function(obj) standardGeneric("content_fun"))

#' @rdname int_methods
setMethod("content_fun", "Split", function(obj) obj@content_fun)

#' @rdname int_methods
setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-"))

#' @rdname int_methods
setMethod("content_fun<-", "Split", function(object, value) {
  object@content_fun <- value
  object
})

#' @rdname int_methods
setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun"))

#' @rdname int_methods
setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun)

#' @rdname int_methods
setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun)

## not used and probably not needed
## #' @rdname int_methods
## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-"))

## #' @rdname int_methods
## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) {
##     object@analysis_fun <- value
##     object
## })
## #' @rdname int_methods
## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) {
##     if(is(value, "function"))
##         value <- list(value)
##     object@analysis_fun <- value
##     object
## })

#' @rdname int_methods
setGeneric("split_fun", function(obj) standardGeneric("split_fun"))

#' @rdname int_methods
setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun)

## Only that type of split currently has the slot
## this should probably change? for now  define
## an accessor that just returns NULL
#' @rdname int_methods
setMethod("split_fun", "Split", function(obj) NULL)

#' @rdname int_methods
setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-"))

#' @rdname int_methods
setMethod("split_fun<-", "CustomizableSplit", function(obj, value) {
  obj@split_fun <- value
  obj
})

# nocov start
## Only that type of split currently has the slot
## this should probably change? for now  define
## an accessor that just returns NULL
#' @rdname int_methods
setMethod(
  "split_fun<-", "Split",
  function(obj, value) {
    stop(
      "Attempted to set a custom split function on a non-customizable split.",
      "This should not happen, please contact the maintainers."
    )
  }
)
# nocov end

## Content specification related accessors ----

#' @rdname int_methods
setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args"))

#' @rdname int_methods
setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args)

#' @rdname int_methods
setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-"))

#' @rdname int_methods
setMethod("content_extra_args<-", "Split", function(object, value) {
  object@content_extra_args <- value
  object
})

#' @rdname int_methods
setGeneric("content_var", function(obj) standardGeneric("content_var"))

#' @rdname int_methods
setMethod("content_var", "Split", function(obj) obj@content_var)

#' @rdname int_methods
setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-"))

#' @rdname int_methods
setMethod("content_var<-", "Split", function(object, value) {
  object@content_var <- value
  object
})

### Miscellaneous accessors ----

#' @rdname int_methods
setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs"))

#' @rdname int_methods
setMethod(
  "avar_inclNAs", "VAnalyzeSplit",
  function(obj) obj@include_NAs
)

#' @rdname int_methods
setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-"))

#' @rdname int_methods
setMethod(
  "avar_inclNAs<-", "VAnalyzeSplit",
  function(obj, value) {
    obj@include_NAs <- value
  }
)

#' @rdname int_methods
setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar"))

#' @rdname int_methods
setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var)

#' @rdname int_methods
setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order"))

#' @rdname int_methods
setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order)

#' @rdname int_methods
setGeneric(
  "spl_child_order<-",
  function(obj, value) standardGeneric("spl_child_order<-")
)

#' @rdname int_methods
setMethod(
  "spl_child_order<-", "VarLevelSplit",
  function(obj, value) {
    obj@value_order <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "ManualSplit",
  function(obj) obj@levels
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "MultiVarSplit",
  function(obj) spl_varnames(obj)
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "AllSplit",
  function(obj) character()
)

#' @rdname int_methods
setMethod(
  "spl_child_order",
  "VarStaticCutSplit",
  function(obj) spl_cutlabels(obj)
)

#' @rdname int_methods
setGeneric("root_spl", function(obj) standardGeneric("root_spl"))

#' @rdname int_methods
setMethod(
  "root_spl", "PreDataAxisLayout",
  function(obj) obj@root_split
)

#' @rdname int_methods
setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-"))

#' @rdname int_methods
setMethod(
  "root_spl<-", "PreDataAxisLayout",
  function(obj, value) {
    obj@root_split <- value
    obj
  }
)

#' Row attribute accessors
#'
#' @inheritParams gen_args
#'
#' @return Various return values depending on the accessor called.
#'
#' @export
#' @rdname row_accessors
setGeneric("obj_avar", function(obj) standardGeneric("obj_avar"))

#' @rdname row_accessors
#' @exportMethod obj_avar
setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed)

#' @rdname row_accessors
#' @exportMethod obj_avar
setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed)

#' @export
#' @rdname row_accessors
setGeneric("row_cells", function(obj) standardGeneric("row_cells"))

#' @rdname row_accessors
#' @exportMethod row_cells
setMethod("row_cells", "TableRow", function(obj) obj@leaf_value)

#' @rdname row_accessors
setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-"))

#' @rdname row_accessors
#' @exportMethod row_cells
setMethod("row_cells<-", "TableRow", function(obj, value) {
  obj@leaf_value <- value
  obj
})

#' @export
#' @rdname row_accessors
setGeneric("row_values", function(obj) standardGeneric("row_values"))

#' @rdname row_accessors
#' @exportMethod row_values
setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value))


#' @rdname row_accessors
#' @exportMethod row_values<-
setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-"))

#' @rdname row_accessors
#' @exportMethod row_values<-
setMethod(
  "row_values<-", "TableRow",
  function(obj, value) {
    obj@leaf_value <- lapply(value, rcell)
    obj
  }
)

#' @rdname row_accessors
#' @exportMethod row_values<-
setMethod(
  "row_values<-", "LabelRow",
  function(obj, value) {
    stop("LabelRows cannot have row values.")
  }
)

#' @rdname int_methods
setGeneric("spanned_values", function(obj) standardGeneric("spanned_values"))

#' @rdname int_methods
setMethod(
  "spanned_values", "TableRow",
  function(obj) {
    rawvalues(spanned_cells(obj))
  }
)

#' @rdname int_methods
setMethod(
  "spanned_values", "LabelRow",
  function(obj) {
    rep(list(NULL), ncol(obj))
  }
)

#' @rdname int_methods
setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells"))

#' @rdname int_methods
setMethod(
  "spanned_cells", "TableRow",
  function(obj) {
    sp <- row_cspans(obj)
    rvals <- row_cells(obj)
    unlist(
      mapply(function(v, s) rep(list(v), times = s),
        v = rvals, s = sp
      ),
      recursive = FALSE
    )
  }
)

#' @rdname int_methods
setMethod(
  "spanned_cells", "LabelRow",
  function(obj) {
    rep(list(NULL), ncol(obj))
  }
)

#' @rdname int_methods
setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-"))

#' @rdname int_methods
setMethod(
  "spanned_values<-", "TableRow",
  function(obj, value) {
    sp <- row_cspans(obj)
    ## this is 3 times too clever!!!
    valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1))))

    splvec <- cumsum(valindices)
    lapply(
      split(value, splvec),
      function(v) {
        if (length(unique(v)) > 1) {
          stop(
            "Got more than one unique value within a span, ",
            "new spanned values do not appear to match the ",
            "existing spanning pattern of the row (",
            paste(sp, collapse = " "), ")"
          )
        }
      }
    )
    rvals <- value[valindices]

    ## rvals = lapply(split(value, splvec),
    ##                function(v) {
    ##     if(length(v) == 1)
    ##         return(v)
    ##     stopifnot(length(unique(v)) == 1L)
    ##     rcell(unique(v), colspan<- length(v))
    ## })
    ## if(any(splvec > 1))
    ##     rvals <- lapply(rvals, function(x) x[[1]])
    row_values(obj) <- rvals
    obj
  }
)

#' @rdname int_methods
setMethod(
  "spanned_values<-", "LabelRow",
  function(obj, value) {
    if (!is.null(value)) {
      stop("Label rows can't have non-null cell values, got", value)
    }
    obj
  }
)

### Format manipulation
### obj_format<- is not recursive
## TODO export these?
#' @rdname formatters_methods
#' @export
setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format)

#' @rdname formatters_methods
#' @export
setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE))

#' @rdname formatters_methods
#' @export
setMethod("obj_format", "Split", function(obj) obj@split_format)

#' @rdname formatters_methods
#' @export
setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) {
  obj@format <- value
  obj
})

#' @rdname formatters_methods
#' @export
setMethod("obj_format<-", "Split", function(obj, value) {
  obj@split_format <- value
  obj
})

#' @rdname formatters_methods
#' @export
setMethod("obj_format<-", "CellValue", function(obj, value) {
  attr(obj, "format") <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str<-", "CellValue", function(obj, value) {
  attr(obj, "format_na_str") <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) {
  obj@na_str <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str<-", "Split", function(obj, value) {
  obj@split_na_str <- value
  obj
})

#' @rdname int_methods
#' @export
setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str)

#' @rdname formatters_methods
#' @export
setMethod("obj_na_str", "Split", function(obj) obj@split_na_str)

.no_na_str <- function(x) {
  if (!is.character(x)) {
    x <- obj_na_str(x)
  }
  length(x) == 0 || all(is.na(x))
}

#' @rdname int_methods
setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) {
  standardGeneric("set_format_recursive")
})

#' @param override (`flag`)\cr whether to override attribute.
#'
#' @rdname int_methods
setMethod(
  "set_format_recursive", "TableRow",
  function(obj, format, na_str, override = FALSE) {
    if (is.null(format) && .no_na_str(na_str)) {
      return(obj)
    }

    if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
      obj_format(obj) <- format
    }
    if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
      obj_na_str(obj) <- na_str
    }
    lcells <- row_cells(obj)
    lvals <- lapply(lcells, function(x) {
      if (!is.null(x) && (override || is.null(obj_format(x)))) {
        obj_format(x) <- obj_format(obj)
      }
      if (!is.null(x) && (override || .no_na_str(x))) {
        obj_na_str(x) <- obj_na_str(obj)
      }
      x
    })
    row_values(obj) <- lvals
    obj
  }
)

#' @rdname int_methods
setMethod(
  "set_format_recursive", "LabelRow",
  function(obj, format, override = FALSE) obj
)

setMethod(
  "set_format_recursive", "VTableTree",
  function(obj, format, na_str, override = FALSE) {
    force(format)
    if (is.null(format) && .no_na_str(na_str)) {
      return(obj)
    }

    if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
      obj_format(obj) <- format
    }
    if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
      obj_na_str(obj) <- na_str
    }

    kids <- tree_children(obj)
    kids <- lapply(kids, function(x, format2, na_str2, oride) {
      set_format_recursive(x,
        format = format2, na_str = na_str2, override = oride
      )
    },
    format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override
    )
    tree_children(obj) <- kids
    obj
  }
)

#' @rdname int_methods
setGeneric("content_format", function(obj) standardGeneric("content_format"))

#' @rdname int_methods
setMethod("content_format", "Split", function(obj) obj@content_format)

#' @rdname int_methods
setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-"))

#' @rdname int_methods
setMethod("content_format<-", "Split", function(obj, value) {
  obj@content_format <- value
  obj
})

#' @rdname int_methods
setGeneric("content_na_str", function(obj) standardGeneric("content_na_str"))

#' @rdname int_methods
setMethod("content_na_str", "Split", function(obj) obj@content_na_str)

#' @rdname int_methods
setGeneric("content_na_str<-", function(obj, value) standardGeneric("content_na_str<-"))

#' @rdname int_methods
setMethod("content_na_str<-", "Split", function(obj, value) {
  obj@content_na_str <- value
  obj
})

#' Value formats
#'
#' Returns a matrix of formats for the cells in a table.
#'
#' @param obj (`VTableTree` or `TableRow`)\cr a table or row object.
#' @param default (`string`, `function`, or `list`)\cr default format.
#'
#' @return Matrix (storage mode list) containing the effective format for each cell position in the table
#'   (including 'virtual' cells implied by label rows, whose formats are always `NULL`).
#'
#' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' value_formats(tbl)
#'
#' @export
setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats"))

#' @rdname value_formats
setMethod(
  "value_formats", "ANY",
  function(obj, default) {
    obj_format(obj) %||% default
  }
)

#' @rdname value_formats
setMethod(
  "value_formats", "TableRow",
  function(obj, default) {
    if (!is.null(obj_format(obj))) {
      default <- obj_format(obj)
    }
    formats <- lapply(row_cells(obj), function(x) value_formats(x) %||% default)
    formats
  }
)

#' @rdname value_formats
setMethod(
  "value_formats", "LabelRow",
  function(obj, default) {
    rep(list(NULL), ncol(obj))
  }
)

#' @rdname value_formats
setMethod(
  "value_formats", "VTableTree",
  function(obj, default) {
    if (!is.null(obj_format(obj))) {
      default <- obj_format(obj)
    }
    rws <- collect_leaves(obj, TRUE, TRUE)
    formatrws <- lapply(rws, value_formats, default = default)
    mat <- do.call(rbind, formatrws)
    row.names(mat) <- row.names(obj)
    mat
  }
)

### Collect all leaves of a current tree
### This is a workhorse function in various
### places
### NB this is written generally enought o
### be used on all tree-based structures in the
### framework.

#' Collect leaves of a `TableTree`
#'
#' @inheritParams gen_args
#' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`.
#' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`.
#'
#' @return A list of `TableRow` objects for all rows in the table.
#'
#' @export
setGeneric("collect_leaves",
  function(tt, incl.cont = TRUE, add.labrows = FALSE) {
    standardGeneric("collect_leaves")
  },
  signature = "tt"
)

#' @inheritParams collect_leaves
#'
#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "TableTree",
  function(tt, incl.cont = TRUE, add.labrows = FALSE) {
    ret <- c(
      if (add.labrows && labelrow_visible(tt)) {
        tt_labelrow(tt)
      },
      if (incl.cont) {
        tree_children(content_table(tt))
      },
      lapply(tree_children(tt),
        collect_leaves,
        incl.cont = incl.cont, add.labrows = add.labrows
      )
    )
    unlist(ret, recursive = TRUE)
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "ElementaryTable",
  function(tt, incl.cont = TRUE, add.labrows = FALSE) {
    ret <- tree_children(tt)
    if (add.labrows && labelrow_visible(tt)) {
      ret <- c(tt_labelrow(tt), ret)
    }
    ret
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "VTree",
  function(tt, incl.cont, add.labrows) {
    ret <- lapply(
      tree_children(tt),
      collect_leaves
    )
    unlist(ret, recursive = TRUE)
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "VLeaf",
  function(tt, incl.cont, add.labrows) {
    list(tt)
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "NULL",
  function(tt, incl.cont, add.labrows) {
    list()
  }
)

#' @rdname int_methods
#' @exportMethod collect_leaves
setMethod(
  "collect_leaves", "ANY",
  function(tt, incl.cont, add.labrows) {
    stop("class ", class(tt), " does not inherit from VTree or VLeaf")
  }
)

n_leaves <- function(tt, ...) {
  length(collect_leaves(tt, ...))
}

### Spanning information ----

#' @rdname int_methods
setGeneric("row_cspans", function(obj) standardGeneric("row_cspans"))

#' @rdname int_methods
setMethod("row_cspans", "TableRow", function(obj) obj@colspans)

#' @rdname int_methods
setMethod(
  "row_cspans", "LabelRow",
  function(obj) rep(1L, ncol(obj))
)

#' @rdname int_methods
setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-"))

#' @rdname int_methods
setMethod("row_cspans<-", "TableRow", function(obj, value) {
  obj@colspans <- value
  obj
})

#' @rdname int_methods
setMethod("row_cspans<-", "LabelRow", function(obj, value) {
  stop("attempted to set colspans for LabelRow") # nocov
})

## XXX TODO colapse with above?
#' @rdname int_methods
setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan"))

#' @rdname int_methods
setMethod(
  "cell_cspan", "CellValue",
  function(obj) attr(obj, "colspan", exact = TRUE)
) ## obj@colspan)

#' @rdname int_methods
setGeneric(
  "cell_cspan<-",
  function(obj, value) standardGeneric("cell_cspan<-")
)

#' @rdname int_methods
setMethod("cell_cspan<-", "CellValue", function(obj, value) {
  ##  obj@colspan <- value
  attr(obj, "colspan") <- value
  obj
})

#' @rdname int_methods
setGeneric("cell_align", function(obj) standardGeneric("cell_align"))

#' @rdname int_methods
setMethod(
  "cell_align", "CellValue",
  function(obj) attr(obj, "align", exact = TRUE) %||% "center"
) ## obj@colspan)

#' @rdname int_methods
setGeneric(
  "cell_align<-",
  function(obj, value) standardGeneric("cell_align<-")
)

#' @rdname int_methods
setMethod("cell_align<-", "CellValue", function(obj, value) {
  ##  obj@colspan <- value
  if (is.null(value)) {
    value <- "center"
  } else {
    value <- tolower(value)
  }
  check_aligns(value)
  attr(obj, "align") <- value
  obj
})

### Level (indent) in tree structure ----

#' @rdname int_methods
setGeneric("tt_level", function(obj) standardGeneric("tt_level"))

## this will hit everything via inheritence
#' @rdname int_methods
setMethod("tt_level", "VNodeInfo", function(obj) obj@level)

#' @rdname int_methods
setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-"))

## this will hit everyhing via inheritence
#' @rdname int_methods
setMethod("tt_level<-", "VNodeInfo", function(obj, value) {
  obj@level <- as.integer(value)
  obj
})

#' @rdname int_methods
setMethod(
  "tt_level<-", "VTableTree",
  function(obj, value) {
    obj@level <- as.integer(value)
    tree_children(obj) <- lapply(tree_children(obj),
      `tt_level<-`,
      value = as.integer(value) + 1L
    )
    obj
  }
)

#' @rdname int_methods
#' @export
setGeneric("indent_mod", function(obj) standardGeneric("indent_mod"))

#' @rdname int_methods
setMethod(
  "indent_mod", "Split",
  function(obj) obj@indent_modifier
)

#' @rdname int_methods
setMethod(
  "indent_mod", "VTableNodeInfo",
  function(obj) obj@indent_modifier
)

#' @rdname int_methods
setMethod(
  "indent_mod", "ANY",
  function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L
)

#' @rdname int_methods
setMethod(
  "indent_mod", "RowsVerticalSection",
  ##          function(obj) setNames(obj@indent_mods,names(obj)))
  function(obj) {
    val <- attr(obj, "indent_mods", exact = TRUE) %||%
      vapply(obj, indent_mod, 1L) ## rep(0L, length(obj))
    setNames(val, names(obj))
  }
)

#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' indent_mod(tbl)
#' indent_mod(tbl) <- 1L
#' tbl
#'
#' @rdname int_methods
#' @export
setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-"))

#' @rdname int_methods
setMethod(
  "indent_mod<-", "Split",
  function(obj, value) {
    obj@indent_modifier <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "indent_mod<-", "VTableNodeInfo",
  function(obj, value) {
    obj@indent_modifier <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "indent_mod<-", "CellValue",
  function(obj, value) {
    attr(obj, "indent_mod") <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "indent_mod<-", "RowsVerticalSection",
  function(obj, value) {
    if (length(value) != 1 && length(value) != length(obj)) {
      stop(
        "When setting indent mods on a RowsVerticalSection the value ",
        "must have length 1 or the number of rows"
      )
    }
    attr(obj, "indent_mods") <- as.integer(value)
    obj

    ## obj@indent_mods <- value
    ## obj
  }
)

#' @rdname int_methods
setGeneric(
  "content_indent_mod",
  function(obj) standardGeneric("content_indent_mod")
)

#' @rdname int_methods
setMethod(
  "content_indent_mod", "Split",
  function(obj) obj@content_indent_modifier
)

#' @rdname int_methods
setMethod(
  "content_indent_mod", "VTableNodeInfo",
  function(obj) obj@content_indent_modifier
)

#' @rdname int_methods
setGeneric(
  "content_indent_mod<-",
  function(obj, value) standardGeneric("content_indent_mod<-")
)

#' @rdname int_methods
setMethod(
  "content_indent_mod<-", "Split",
  function(obj, value) {
    obj@content_indent_modifier <- as.integer(value)
    obj
  }
)

#' @rdname int_methods
setMethod(
  "content_indent_mod<-", "VTableNodeInfo",
  function(obj, value) {
    obj@content_indent_modifier <- as.integer(value)
    obj
  }
)

## TODO export these?
#' @rdname int_methods
#' @export
setGeneric("rawvalues", function(obj) standardGeneric("rawvalues"))

#' @rdname int_methods
setMethod("rawvalues", "ValueWrapper", function(obj) obj@value)

#' @rdname int_methods
setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels)

#' @rdname int_methods
setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues))

#' @rdname int_methods
setMethod("rawvalues", "ANY", function(obj) obj)

#' @rdname int_methods
setMethod("rawvalues", "CellValue", function(obj) obj[[1]])

#' @rdname int_methods
setMethod(
  "rawvalues", "TreePos",
  function(obj) rawvalues(pos_splvals(obj))
)

#' @rdname int_methods
setMethod(
  "rawvalues", "RowsVerticalSection",
  function(obj) unlist(obj, recursive = FALSE)
)

#' @rdname int_methods
#' @export
setGeneric("value_names", function(obj) standardGeneric("value_names"))

#' @rdname int_methods
setMethod(
  "value_names", "ANY",
  function(obj) as.character(rawvalues(obj))
)

#' @rdname int_methods
setMethod(
  "value_names", "TreePos",
  function(obj) value_names(pos_splvals(obj))
)

#' @rdname int_methods
setMethod(
  "value_names", "list",
  function(obj) lapply(obj, value_names)
)

#' @rdname int_methods
setMethod(
  "value_names", "ValueWrapper",
  function(obj) rawvalues(obj)
)

#' @rdname int_methods
setMethod(
  "value_names", "LevelComboSplitValue",
  function(obj) obj@value
) ## obj@comboname)

#' @rdname int_methods
setMethod(
  "value_names", "RowsVerticalSection",
  function(obj) attr(obj, "row_names", exact = TRUE)
) ## obj@row_names)

## not sure if I need these anywhere
## XXX
#' @rdname int_methods
setGeneric("value_labels", function(obj) standardGeneric("value_labels"))

#' @rdname int_methods
setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj)))

#' @rdname int_methods
setMethod(
  "value_labels", "TreePos",
  function(obj) sapply(pos_splvals(obj), obj_label)
)

#' @rdname int_methods
setMethod("value_labels", "list", function(obj) {
  ret <- lapply(obj, obj_label)
  if (!is.null(names(obj))) {
    inds <- vapply(ret, function(x) length(x) == 0, NA)
    ret[inds] <- names(obj)[inds]
  }
  ret
})

#' @rdname int_methods
setMethod(
  "value_labels",
  "RowsVerticalSection",
  function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj))
)

#' @rdname int_methods
setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj))

#' @rdname int_methods
setMethod(
  "value_labels", "LevelComboSplitValue",
  function(obj) obj_label(obj)
)

#' @rdname int_methods
setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)

#' @rdname int_methods
setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
#' @rdname int_methods
setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
#' @rdname int_methods
setMethod("value_expr", "ANY", function(obj) NULL)
## no setters for now, we'll see about that.

#' @rdname int_methods
setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels"))

#' @rdname int_methods
setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels)

#' @rdname int_methods
setGeneric(
  "spl_varlabels<-",
  function(object, value) standardGeneric("spl_varlabels<-")
)

#' @rdname int_methods
setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
  object@var_labels <- value
  object
})

## These two are similar enough we could probably combine
## them but conceptually they are pretty different
## split_exargs is a list of extra arguments that apply
## to *all the chidlren*,
## while splv_extra is for *child-specific* extra arguments,
## associated with specific values of the split
#' @rdname int_methods
setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))

#' @rdname int_methods
setMethod(
  "splv_extra", "SplitValue",
  function(obj) obj@extra
)

#' @rdname int_methods
setGeneric(
  "splv_extra<-",
  function(obj, value) standardGeneric("splv_extra<-")
)
#' @rdname int_methods
setMethod(
  "splv_extra<-", "SplitValue",
  function(obj, value) {
    obj@extra <- value
    obj
  }
)

#' @rdname int_methods
setGeneric("split_exargs", function(obj) standardGeneric("split_exargs"))

#' @rdname int_methods
setMethod(
  "split_exargs", "Split",
  function(obj) obj@extra_args
)

#' @rdname int_methods
setGeneric(
  "split_exargs<-",
  function(obj, value) standardGeneric("split_exargs<-")
)

#' @rdname int_methods
setMethod(
  "split_exargs<-", "Split",
  function(obj, value) {
    obj@extra_args <- value
    obj
  }
)

is_labrow <- function(obj) is(obj, "LabelRow")

spl_ref_group <- function(obj) {
  stopifnot(is(obj, "VarLevWBaselineSplit"))
  obj@ref_group_value
}

### column info

#' Column information/structure accessors
#'
#' @inheritParams gen_args
#' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being
#'   generated from a pre-data layout object.
#' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only.
#'   Path (in column structure).
#' @param rtpos (`TreePos`)\cr root position.
#'
#' @return A `LayoutColTree` object.
#'
#' @rdname col_accessors
#' @export
setGeneric("clayout", function(obj) standardGeneric("clayout"))

#' @rdname col_accessors
#' @exportMethod clayout
setMethod(
  "clayout", "VTableNodeInfo",
  function(obj) coltree(col_info(obj))
)

#' @rdname col_accessors
#' @exportMethod clayout
setMethod(
  "clayout", "PreDataTableLayouts",
  function(obj) obj@col_layout
)

## useful convenience for the cascading methods in colby_constructors
#' @rdname col_accessors
#' @exportMethod clayout
setMethod("clayout", "ANY", function(obj) PreDataColLayout())

#' @rdname col_accessors
#' @export
setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-"))

#' @rdname col_accessors
#' @exportMethod clayout<-
setMethod(
  "clayout<-", "PreDataTableLayouts",
  function(object, value) {
    object@col_layout <- value
    object
  }
)

#' @rdname col_accessors
#' @export
setGeneric("col_info", function(obj) standardGeneric("col_info"))

#' @rdname col_accessors
#' @exportMethod col_info
setMethod(
  "col_info", "VTableNodeInfo",
  function(obj) obj@col_info
)

### XXX I've made this recursive. Do we ALWAYS want it to be?
###
### I think we do.
#' @rdname col_accessors
#' @export
setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-"))

#' @return Returns various information about columns, depending on the accessor used.
#'
#' @exportMethod col_info<-
#' @rdname col_accessors
setMethod(
  "col_info<-", "TableRow",
  function(obj, value) {
    obj@col_info <- value
    obj
  }
)

.set_cinfo_kids <- function(obj) {
  kids <- lapply(
    tree_children(obj),
    function(x) {
      col_info(x) <- col_info(obj)
      x
    }
  )
  tree_children(obj) <- kids
  obj
}

#' @rdname col_accessors
#' @exportMethod col_info<-
setMethod(
  "col_info<-", "ElementaryTable",
  function(obj, value) {
    obj@col_info <- value
    .set_cinfo_kids(obj)
  }
)

#' @rdname col_accessors
#' @exportMethod col_info<-
setMethod(
  "col_info<-", "TableTree",
  function(obj, value) {
    obj@col_info <- value
    if (nrow(content_table(obj))) {
      ct <- content_table(obj)
      col_info(ct) <- value
      content_table(obj) <- ct
    }
    .set_cinfo_kids(obj)
  }
)

#' @rdname col_accessors
#' @param ccount_format (`FormatSpec`)\cr The format to be used by default for column
#' counts throughout this column tree (i.e. if not overridden by a more specific format
#' specification).
#' @export
setGeneric(
  "coltree",
  function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format = "(N=xx)") standardGeneric("coltree")
)

#' @rdname col_accessors
#' @exportMethod coltree
setMethod(
  "coltree", "InstantiatedColumnInfo",
  function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format) {
    if (!is.null(df)) {
      warning("Ignoring df argument and retrieving already-computed LayoutColTree")
    }
    obj@tree_layout
  }
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "PreDataTableLayouts",
  function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
    coltree(clayout(obj), df, rtpos, alt_counts_df = alt_counts_df, ccount_format = ccount_format)
  }
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "PreDataColLayout",
  function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
    obj <- set_def_child_ord(obj, df)
    kids <- lapply(
      obj,
      function(x) {
        splitvec_to_coltree(
          df = df,
          splvec = x,
          pos = rtpos,
          alt_counts_df = alt_counts_df,
          global_cc_format = ccount_format
        )
      }
    )
    if (length(kids) == 1) {
      res <- kids[[1]]
    } else {
      res <- LayoutColTree(
        lev = 0L,
        kids = kids,
        tpos = rtpos,
        spl = RootSplit(),
        colcount = NROW(alt_counts_df),
        colcount_format = ccount_format
      )
    }
    disp_ccounts(res) <- disp_ccounts(obj)
    res
  }
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "LayoutColTree",
  function(obj, df, rtpos, alt_counts_df, ccount_format) obj
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "VTableTree",
  function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))
)

#' @rdname col_accessors
#' @export coltree
setMethod(
  "coltree", "TableRow",
  function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))
)

setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-"))
setMethod(
  "coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"),
  function(obj, value) {
    obj@tree_layout <- value
    obj
  }
)

setMethod(
  "coltree<-", c("VTableTree", "LayoutColTree"),
  function(obj, value) {
    cinfo <- col_info(obj)
    coltree(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname col_accessors
#' @export
setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs"))

#' @rdname col_accessors
#' @export col_exprs
setMethod(
  "col_exprs", "PreDataTableLayouts",
  function(obj, df = NULL) col_exprs(clayout(obj), df)
)

#' @rdname col_accessors
#' @export col_exprs
setMethod(
  "col_exprs", "PreDataColLayout",
  function(obj, df = NULL) {
    if (is.null(df)) {
      stop("can't determine col_exprs without data")
    }
    ct <- coltree(obj, df = df)
    make_col_subsets(ct, df = df)
  }
)

#' @rdname col_accessors
#' @export col_exprs
setMethod(
  "col_exprs", "InstantiatedColumnInfo",
  function(obj, df = NULL) {
    if (!is.null(df)) {
      warning("Ignoring df method when extracted precomputed column subsetting expressions.")
    }
    obj@subset_exprs
  }
)

#' @rdname int_methods
setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args"))

#' @rdname int_methods
setMethod(
  "col_extra_args", "InstantiatedColumnInfo",
  function(obj, df) {
    if (!is.null(df)) {
      warning("Ignorning df when retrieving already-computed column extra arguments.")
    }
    obj@cextra_args
  }
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "PreDataTableLayouts",
  function(obj, df) col_extra_args(clayout(obj), df)
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "PreDataColLayout",
  function(obj, df) {
    col_extra_args(coltree(obj, df), NULL)
  }
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "LayoutColTree",
  function(obj, df) {
    if (!is.null(df)) {
      warning("Ignoring df argument and returning already calculated extra arguments")
    }
    get_col_extras(obj)
  }
)

#' @rdname int_methods
setMethod(
  "col_extra_args", "LayoutColLeaf",
  function(obj, df) {
    if (!is.null(df)) {
      warning("Ignoring df argument and returning already calculated extra arguments")
    }

    get_pos_extra(pos = tree_pos(obj))
  }
)

#' @seealso [facet_colcount()]
#' @export
#' @rdname col_accessors
setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts", "InstantiatedColumnInfo",
  function(obj, path = NULL) {
    if (is.null(path)) {
      lfs <- collect_leaves(coltree(obj))
      ret <- vapply(lfs, facet_colcount, 1L, path = NULL)
    } else {
      ret <- facet_colcount(obj, path)
    }
    ## required for strict backwards compatibility,
    ## even though its undesirable behavior.
    unname(ret)
  }
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts", "VTableNodeInfo",
  function(obj, path = NULL) col_counts(col_info(obj), path = path)
)

#' @export
#' @rdname col_accessors
setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts<-", "InstantiatedColumnInfo",
  function(obj, path = NULL, value) {
    ## obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- value
    ## obj
    if (!is.null(path)) {
      all_paths <- list(path)
    } else {
      all_paths <- make_col_df(obj, visible_only = TRUE)$path
    }
    if (length(value) != length(all_paths)) {
      stop(
        "Got ", length(value), " values for ",
        length(all_paths), " column paths",
        if (is.null(path)) " (from path = NULL)",
        "."
      )
    }
    ctree <- coltree(obj)
    for (i in seq_along(all_paths)) {
      facet_colcount(ctree, all_paths[[i]]) <- value[i]
    }
    coltree(obj) <- ctree
    obj
  }
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_counts<-", "VTableNodeInfo",
  function(obj, path = NULL, value) {
    cinfo <- col_info(obj)
    col_counts(cinfo, path = path) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @export
#' @rdname col_accessors
setGeneric("col_total", function(obj) standardGeneric("col_total"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_total", "InstantiatedColumnInfo",
  function(obj) obj@total_count
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_total", "VTableNodeInfo",
  function(obj) col_total(col_info(obj))
)

#' @export
#' @rdname col_accessors
setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-"))

#' @export
#' @rdname col_accessors
setMethod(
  "col_total<-", "InstantiatedColumnInfo",
  function(obj, value) {
    ## all methods funnel to this one so ensure integer-ness here.
    obj@total_count <- as.integer(value)
    obj
  }
)

#' @export
#' @rdname col_accessors
setMethod(
  "col_total<-", "VTableNodeInfo",
  function(obj, value) {
    cinfo <- col_info(obj)
    col_total(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname int_methods
setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts"))

#' @rdname int_methods
setMethod(
  "disp_ccounts", "VTableTree",
  function(obj) disp_ccounts(col_info(obj))
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "InstantiatedColumnInfo",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "PreDataTableLayouts",
  function(obj) disp_ccounts(clayout(obj))
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "PreDataColLayout",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "LayoutColTree",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "LayoutColLeaf",
  function(obj) obj@display_columncounts
)

#' @rdname int_methods
setMethod(
  "disp_ccounts", "Split",
  function(obj) obj@child_show_colcounts
)

#' @rdname int_methods
setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-"))

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "VTableTree",
  function(obj, value) {
    cinfo <- col_info(obj)
    disp_ccounts(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "InstantiatedColumnInfo",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "PreDataColLayout",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "LayoutColTree",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "LayoutColLeaf",
  function(obj, value) {
    obj@display_columncounts <- value
    obj
  }
)

#' @rdname int_methods
setMethod(
  "disp_ccounts<-", "PreDataTableLayouts",
  function(obj, value) {
    clyt <- clayout(obj)
    disp_ccounts(clyt) <- value
    clayout(obj) <- clyt
    obj
  }
)


## this is a horrible hack but when we have non-nested siblings at the top level
## the beginning of the "path <-> position" relationship breaks down.
## we probably *should* have e.g., c("root", "top_level_splname_1",
## "top_level_splname_1, "top_level_splname_1_value", ...)
## but its pretty clear why no one will be happy with that, I think
## so we punt on the problem for now with an explicit workaround
##
## those first non-nested siblings currently have (incorrect)
## empty tree_pos elements so we just look at the obj_name

pos_singleton_path <- function(obj) {
  pos <- tree_pos(obj)
  splvals <- pos_splvals(pos)
  length(splvals) == 0 ||
    (length(splvals) == 1 && is.na(unlist(value_names(splvals))))
}

## close to a duplicate of tt_at_path, but... not quite :(
#' @rdname int_methods
coltree_at_path <- function(obj, path, ...) {
  if (length(path) == 0) {
    return(obj)
  }
  stopifnot(
    is(path, "character"),
    length(path) > 0
  )
  if (any(grepl("@content", path, fixed = TRUE))) {
    stop("@content token is not valid for column paths.")
  }

  cur <- obj
  curpath <- pos_to_path(tree_pos(obj)) # path
  num_consume_path <- 2
  while (!identical(curpath, path) && !is(cur, "LayoutColLeaf")) { # length(curpath) > 0) {
    kids <- tree_children(cur)
    kidmatch <- find_kid_path_match(kids, path)
    if (length(kidmatch) == 0) {
      stop(
        "unable to match full path: ", paste(path, sep = "->"),
        "\n path of last match: ", paste(curpath, sep = "->")
      )
    }
    cur <- kids[[kidmatch]]
    curpath <- pos_to_path(tree_pos(cur))
  }
  cur
}

find_kid_path_match <- function(kids, path) {
  if (length(kids) == 0) {
    return(integer())
  }
  kidpaths <- lapply(kids, function(k) pos_to_path(tree_pos(k)))

  matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)
  firstkidpos <- tree_pos(kids[[1]])
  if (all(matches) && pos_singleton_path(kids[[1]])) {
    kidpaths <- lapply(seq_along(kidpaths), function(i) c(kidpaths[[i]], obj_name(kids[[i]])))
    matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)
  }
  which(matches)
}


## almost a duplicate of recursive_replace, but I spent a bunch
## of time ramming my head against the different way pathing happens
## in column space (unfortunately) before giving up building
## coltree_at_path around recursive_replace, so here we are.

ct_recursive_replace <- function(ctree, path, value, pos = 1) {
  pos <- tree_pos(ctree)
  curpth <- pos_to_path(pos)
  if (identical(path, curpth)) {
    return(value)
  } else if (is(ctree, "LayoutColLeaf")) {
    stop(
      "unable to match full path: ", paste(path, sep = "->"),
      "\n path at leaf: ", paste(curpth, sep = "->")
    )
  }
  kids <- tree_children(ctree)
  kids_singl <- pos_singleton_path(kids[[1]])
  kidind <- find_kid_path_match(kids, path)

  if (length(kidind) == 0) {
    stop("Path appears invalid for this tree at step ", path[1])
  } else if (length(kidind) > 1) {
    stop(
      "singleton step (root, cbind_root, etc) in path appears to have matched multiple children. ",
      "This shouldn't happen, please contact the maintainers."
    )
  }

  kids[[kidind]] <- ct_recursive_replace(
    kids[[kidind]],
    path, value
  )
  tree_children(ctree) <- kids
  ctree
}

`coltree_at_path<-` <- function(obj, path, value) {
  obj <- ct_recursive_replace(obj, path, value)
  obj
}

#' Set visibility of column counts for a group of sibling facets
#'
#' @inheritParams gen_args
#' @param path (`character`)\cr the path *to the parent of the
#'   desired siblings*. The last element in the path should
#'   be a split name.
#' @return obj, modified with the desired column count.
#'   display behavior
#'
#' @seealso [colcount_visible()]
#'
#' @export
`facet_colcounts_visible<-` <- function(obj, path, value) {
  coldf <- make_col_df(obj, visible_only = FALSE)
  allpaths <- coldf$path
  lenpath <- length(path)
  match_paths <- vapply(allpaths, function(path_i) {
    (length(path_i) == lenpath + 1) &&
      (all(head(path_i, -1) == path))
  }, TRUE)
  for (curpath in allpaths[match_paths]) {
    colcount_visible(obj, curpath) <- value
  }
  obj
}

#' Get or set column count for a facet in column space
#'
#' @inheritParams gen_args
#' @param path character. This path must end on a
#' split value, e.g., the level of a categorical variable
#' that was split on in column space, but it need not
#' be the path to an individual column.
#'
#' @return for `facet_colcount` the current count associated
#' with that facet in column space, for `facet_colcount<-`,
#' `obj` modified with the new column count for the specified
#' facet.
#'
#' @note Updating a lower-level (more specific)
#' column count manually **will not** update the
#' counts for its parent facets. This cannot be made
#' automatic because the rtables framework does not
#' require sibling facets to be mutually exclusive
#' (e.g., total "arm", faceting into cumulative
#' quantiles, etc) and thus the count of a parent facet
#' will not always be simply the sum of the counts for
#' all of its children.
#'
#' @seealso [col_counts()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM", show_colcounts = TRUE) %>%
#'   split_cols_by("SEX",
#'     split_fun = keep_split_levels(c("F", "M")),
#'     show_colcounts = TRUE
#'   ) %>%
#'   split_cols_by("STRATA1", show_colcounts = TRUE) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' facet_colcount(tbl, c("ARM", "A: Drug X"))
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F"))
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A"))
#'
#' ## modify specific count after table creation
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A")) <- 25
#'
#' ## show black space for certain counts by assign NA
#'
#' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "C")) <- NA
#'
#' @export
setGeneric(
  "facet_colcount",
  function(obj, path) standardGeneric("facet_colcount")
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "LayoutColTree",
  function(obj, path = NULL) {
    ## if(length(path) == 0L)
    ##   stop("face_colcount requires a non-null path") #nocov
    subtree <- coltree_at_path(obj, path)
    subtree@column_count
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "LayoutColLeaf",
  function(obj, path = NULL) {
    ## not sure if we should check for null here as above
    obj@column_count
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "VTableTree",
  function(obj, path) facet_colcount(coltree(obj), path = path)
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount", "InstantiatedColumnInfo",
  function(obj, path) facet_colcount(coltree(obj), path = path)
)

#' @rdname facet_colcount
#' @export
setGeneric(
  "facet_colcount<-",
  function(obj, path, value) standardGeneric("facet_colcount<-")
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "LayoutColTree",
  function(obj, path, value) {
    ct <- coltree_at_path(obj, path)
    ct@column_count <- as.integer(value)
    coltree_at_path(obj, path) <- ct
    obj
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "LayoutColLeaf",
  function(obj, path, value) {
    obj@column_count <- as.integer(value)
    obj
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "VTableTree",
  function(obj, path, value) {
    cinfo <- col_info(obj)
    facet_colcount(cinfo, path) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname facet_colcount
#' @export
setMethod(
  "facet_colcount<-", "InstantiatedColumnInfo",
  function(obj, path, value) {
    ct <- coltree(obj)
    facet_colcount(ct, path) <- value
    coltree(obj) <- ct
    obj
  }
)

#' Value and Visibility of specific column counts by path
#'
#' @inheritParams gen_args
#'
#' @return for `colcount_visible` a logical scalar
#' indicating whether the specified position in
#' the column hierarchy is set to display its column count;
#' for `colcount_visible<-`, `obj` updated with
#' the specified count displaying behavior set.
#'
#' @note Users generally should not call `colcount_visible`
#' directly, as setting sibling facets to have differing
#' column count visibility will result in an error when
#' printing or paginating the table.
#'
#' @export
setGeneric("colcount_visible", function(obj, path) standardGeneric("colcount_visible"))

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible", "VTableTree",
  function(obj, path) colcount_visible(coltree(obj), path)
)

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible", "InstantiatedColumnInfo",
  function(obj, path) colcount_visible(coltree(obj), path)
)

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible", "LayoutColTree",
  function(obj, path) {
    subtree <- coltree_at_path(obj, path)
    disp_ccounts(subtree)
  }
)

#' @rdname colcount_visible
#' @export
setGeneric("colcount_visible<-", function(obj, path, value) standardGeneric("colcount_visible<-"))

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible<-", "VTableTree",
  function(obj, path, value) {
    ctree <- coltree(obj)
    colcount_visible(ctree, path) <- value
    coltree(obj) <- ctree
    obj
  }
)

#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible<-", "InstantiatedColumnInfo",
  function(obj, path, value) {
    ctree <- coltree(obj)
    colcount_visible(ctree, path) <- value
    coltree(obj) <- ctree
    obj
  }
)


#' @rdname colcount_visible
#' @export
setMethod(
  "colcount_visible<-", "LayoutColTree",
  function(obj, path, value) {
    subtree <- coltree_at_path(obj, path)
    disp_ccounts(subtree) <- value
    coltree_at_path(obj, path) <- subtree
    obj
  }
)

#' @rdname int_methods
#' @export
setGeneric("colcount_format", function(obj) standardGeneric("colcount_format"))

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "InstantiatedColumnInfo",
  function(obj) obj@columncount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "VTableNodeInfo",
  function(obj) colcount_format(col_info(obj))
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "PreDataColLayout",
  function(obj) obj@columncount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "PreDataTableLayouts",
  function(obj) colcount_format(clayout(obj))
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "Split",
  function(obj) obj@child_colcount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "LayoutColTree",
  function(obj) obj@columncount_format
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format", "LayoutColLeaf",
  function(obj) obj@columncount_format
)



#' @rdname int_methods
#' @export
setGeneric(
  "colcount_format<-",
  function(obj, value) standardGeneric("colcount_format<-")
)

#' @export
#' @rdname int_methods
setMethod(
  "colcount_format<-", "InstantiatedColumnInfo",
  function(obj, value) {
    obj@columncount_format <- value
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format<-", "VTableNodeInfo",
  function(obj, value) {
    cinfo <- col_info(obj)
    colcount_format(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format<-", "PreDataColLayout",
  function(obj, value) {
    obj@columncount_format <- value
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_format<-", "PreDataTableLayouts",
  function(obj, value) {
    clyt <- clayout(obj)
    colcount_format(clyt) <- value
    clayout(obj) <- clyt
    obj
  }
)

## It'd probably be better if this had the full set of methods as above
## but its not currently modelled in the class and probably isn't needed
## super much
#' @rdname int_methods
#' @export
setGeneric("colcount_na_str", function(obj) standardGeneric("colcount_na_str"))

#' @rdname int_methods
#' @export
setMethod(
  "colcount_na_str", "InstantiatedColumnInfo",
  function(obj) obj@columncount_na_str
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_na_str", "VTableNodeInfo",
  function(obj) colcount_na_str(col_info(obj))
)

#' @rdname int_methods
#' @export
setGeneric(
  "colcount_na_str<-",
  function(obj, value) standardGeneric("colcount_na_str<-")
)

#' @export
#' @rdname int_methods
setMethod(
  "colcount_na_str<-", "InstantiatedColumnInfo",
  function(obj, value) {
    obj@columncount_na_str <- value
    obj
  }
)

#' @rdname int_methods
#' @export
setMethod(
  "colcount_na_str<-", "VTableNodeInfo",
  function(obj, value) {
    cinfo <- col_info(obj)
    colcount_na_str(cinfo) <- value
    col_info(obj) <- cinfo
    obj
  }
)

#' Exported for use in `tern`
#'
#' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information?
#'
#' @inheritParams gen_args
#'
#' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise.
#'
#' @rdname no_info
#' @export
setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo"))

#' @exportMethod no_colinfo
#' @rdname no_info
setMethod(
  "no_colinfo", "VTableNodeInfo",
  function(obj) no_colinfo(col_info(obj))
)

#' @exportMethod no_colinfo
#' @rdname no_info
setMethod(
  "no_colinfo", "InstantiatedColumnInfo",
  function(obj) length(obj@subset_exprs) == 0
) ## identical(obj, EmptyColInfo))

#' Names of a `TableTree`
#'
#' @param x (`TableTree`)\cr the object.
#'
#' @details
#' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level
#' split values repped out across the columns that they span.
#'
#' @return The column names of `x`, as defined in the details above.
#'
#' @exportMethod names
#' @rdname names
setMethod(
  "names", "VTableNodeInfo",
  function(x) names(col_info(x))
)

#' @rdname names
#' @exportMethod names
setMethod(
  "names", "InstantiatedColumnInfo",
  function(x) names(coltree(x))
)

#' @rdname names
#' @exportMethod names
setMethod(
  "names", "LayoutColTree",
  function(x) {
    unname(unlist(lapply(
      tree_children(x),
      function(obj) {
        nm <- obj_name(obj)
        rep(nm, n_leaves(obj))
      }
    )))
  }
)

#' @rdname names
#' @exportMethod row.names
setMethod(
  "row.names", "VTableTree",
  function(x) {
    unname(sapply(collect_leaves(x, add.labrows = TRUE),
      obj_label,
      USE.NAMES = FALSE
    )) ## XXXX this should probably be obj_name???
  }
)

#' Convert to a vector
#'
#' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in
#' realistic scenarios.
#'
#' @param x (`ANY`)\cr the object to be converted to a vector.
#' @param mode (`string`)\cr passed on to [as.vector()].
#'
#' @return A vector of the chosen mode (or an error is raised if more than one row was present).
#'
#' @note This only works for a table with a single row or a row object.
#'
#' @name asvec
#' @aliases as.vector,VTableTree-method
#' @exportMethod as.vector
setMethod("as.vector", "VTableTree", function(x, mode) {
  stopifnot(nrow(x) == 1L)
  if (nrow(content_table(x)) == 1L) {
    tab <- content_table(x)
  } else {
    tab <- x
  }
  as.vector(tree_children(tab)[[1]], mode = mode)
})

#' @inheritParams asvec
#'
#' @rdname int_methods
#' @exportMethod as.vector
setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode))

#' @rdname int_methods
#' @exportMethod as.vector
setMethod("as.vector", "ElementaryTable", function(x, mode) {
  stopifnot(nrow(x) == 1L)
  as.vector(tree_children(x)[[1]], mode = mode)
})

## cuts ----

#' @rdname int_methods
setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts"))

#' @rdname int_methods
setMethod(
  "spl_cuts", "VarStaticCutSplit",
  function(obj) obj@cuts
)

#' @rdname int_methods
setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels"))

#' @rdname int_methods
setMethod(
  "spl_cutlabels", "VarStaticCutSplit",
  function(obj) obj@cut_labels
)

#' @rdname int_methods
setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun"))

#' @rdname int_methods
setMethod(
  "spl_cutfun", "VarDynCutSplit",
  function(obj) obj@cut_fun
)

#' @rdname int_methods
setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun"))

#' @rdname int_methods
setMethod(
  "spl_cutlabelfun", "VarDynCutSplit",
  function(obj) obj@cut_label_fun
)

#' @rdname int_methods
setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts"))

#' @rdname int_methods
setMethod(
  "spl_is_cmlcuts", "VarDynCutSplit",
  function(obj) obj@cumulative_cuts
)

#' @rdname int_methods
setGeneric(
  "spl_varnames",
  function(obj) standardGeneric("spl_varnames")
)

#' @rdname int_methods
setMethod(
  "spl_varnames", "MultiVarSplit",
  function(obj) obj@var_names
)

#' @rdname int_methods
setGeneric(
  "spl_varnames<-",
  function(object, value) standardGeneric("spl_varnames<-")
)

#' @rdname int_methods
setMethod(
  "spl_varnames<-", "MultiVarSplit",
  function(object, value) {
    oldvnms <- spl_varnames(object)
    oldvlbls <- spl_varlabels(object)
    object@var_names <- value
    if (identical(oldvnms, oldvlbls)) {
      spl_varlabels(object) <- value
    }
    object
  }
)

#' Top left material
#'
#' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the
#' area of the table between the column header display and the label of the first row. These functions access
#' and modify that material.
#'
#' @inheritParams gen_args
#'
#' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the
#'   case of the setter).
#'
#' @export
#' @rdname top_left
setGeneric("top_left", function(obj) standardGeneric("top_left"))

#' @export
#' @rdname top_left
setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj)))

#' @export
#' @rdname top_left
setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left)

#' @export
#' @rdname top_left
setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left)

#' @export
#' @rdname top_left
setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-"))

#' @export
#' @rdname top_left
setMethod("top_left<-", "VTableTree", function(obj, value) {
  cinfo <- col_info(obj)
  top_left(cinfo) <- value
  col_info(obj) <- cinfo
  obj
})

#' @export
#' @rdname top_left
setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) {
  obj@top_left <- value
  obj
})

#' @export
#' @rdname top_left
setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) {
  obj@top_left <- value
  obj
})

vil_collapse <- function(x) {
  x <- unlist(x)
  x <- x[!is.na(x)]
  x <- unique(x)
  x[nzchar(x)]
}

#' List variables required by a pre-data table layout
#'
#' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof).
#'
#' @details
#' This will walk the layout declaration and return a vector of the names of the unique variables that are used
#' in any of the following ways:
#'
#'   * Variable being split on (directly or via cuts)
#'   * Element of a Multi-variable column split
#'   * Content variable
#'   * Value-label variable
#'
#' @return A character vector containing the unique variables explicitly used in the layout (see the notes below).
#'
#' @note
#' * This function will not detect dependencies implicit in analysis or summary functions which accept `x`
#'   or `df` and then rely on the existence of particular variables not being split on/analyzed.
#' * The order these variable names appear within the return vector is undefined and should not be relied upon.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   summarize_row_groups(label_fstr = "Overall (N)") %>%
#'   split_rows_by("RACE",
#'     split_label = "Ethnicity", labels_var = "ethn_lab",
#'     split_fun = drop_split_levels
#'   ) %>%
#'   summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
#'   analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
#'
#' vars_in_layout(lyt)
#'
#' @export
#' @rdname vil
setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout"))

#' @rdname vil
setMethod(
  "vars_in_layout", "PreDataTableLayouts",
  function(lyt) {
    vil_collapse(c(
      vars_in_layout(clayout(lyt)),
      vars_in_layout(rlayout(lyt))
    ))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "PreDataAxisLayout",
  function(lyt) {
    vil_collapse(lapply(lyt, vars_in_layout))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "SplitVector",
  function(lyt) {
    vil_collapse(lapply(lyt, vars_in_layout))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "Split",
  function(lyt) {
    vil_collapse(c(
      spl_payload(lyt),
      ## for an AllSplit/RootSplit
      ## doesn't have to be same as payload
      content_var(lyt),
      spl_label_var(lyt)
    ))
  }
)

#' @rdname vil
setMethod(
  "vars_in_layout", "CompoundSplit",
  function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout))
)

#' @rdname vil
setMethod(
  "vars_in_layout", "ManualSplit",
  function(lyt) character()
)

## Titles and footers ----

# ##' Titles and Footers
# ##'
# ##' Get or set the titles and footers on an object
# ##'
# ##' @inheritParams gen_args
# ##'
# ##' @rdname title_footer
# ##' @export
#' @rdname formatters_methods
#' @export
setMethod(
  "main_title", "VTitleFooter",
  function(obj) obj@main_title
)

##' @rdname formatters_methods
##' @export
setMethod(
  "main_title<-", "VTitleFooter",
  function(obj, value) {
    stopifnot(length(value) == 1)
    obj@main_title <- value
    obj
  }
)

# Getters for TableRow is here for convenience for binding (no need of setters)
#' @rdname formatters_methods
#' @export
setMethod(
  "main_title", "TableRow",
  function(obj) ""
)

#' @rdname formatters_methods
#' @export
setMethod(
  "subtitles", "VTitleFooter",
  function(obj) obj@subtitles
)

#' @rdname formatters_methods
#' @export
setMethod(
  "subtitles<-", "VTitleFooter",
  function(obj, value) {
    obj@subtitles <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "subtitles", "TableRow", # Only getter: see main_title for TableRow
  function(obj) character()
)

#' @rdname formatters_methods
#' @export
setMethod(
  "main_footer", "VTitleFooter",
  function(obj) obj@main_footer
)

#' @rdname formatters_methods
#' @export
setMethod(
  "main_footer<-", "VTitleFooter",
  function(obj, value) {
    obj@main_footer <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "main_footer", "TableRow", # Only getter: see main_title for TableRow
  function(obj) character()
)

#' @rdname formatters_methods
#' @export
setMethod(
  "prov_footer", "VTitleFooter",
  function(obj) obj@provenance_footer
)

#' @rdname formatters_methods
#' @export
setMethod(
  "prov_footer<-", "VTitleFooter",
  function(obj, value) {
    obj@provenance_footer <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "prov_footer", "TableRow", # Only getter: see main_title for TableRow
  function(obj) character()
)

make_ref_value <- function(value) {
  if (is(value, "RefFootnote")) {
    value <- list(value)
  } else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) {
    value <- lapply(value, RefFootnote)
  }
  value
}

#' Referential footnote accessors
#'
#' Access and set the referential footnotes aspects of a built table.
#'
#' @inheritParams gen_args
#'
#' @export
#' @rdname ref_fnotes
setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes"))

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes", "TableRow",
  function(obj) obj@row_footnotes
)

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes", "RowsVerticalSection",
  function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list()
)

#' @export
#' @rdname ref_fnotes
setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-"))

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes<-", "TableRow",
  function(obj, value) {
    obj@row_footnotes <- make_ref_value(value)
    obj
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "row_footnotes", "VTableTree",
  function(obj) {
    rws <- collect_leaves(obj, TRUE, TRUE)
    cells <- lapply(rws, row_footnotes)
    cells
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes"))

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "CellValue",
  function(obj) attr(obj, "footnotes", exact = TRUE) %||% list()
)

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "TableRow",
  function(obj) {
    ret <- lapply(row_cells(obj), cell_footnotes)
    if (length(ret) != ncol(obj)) {
      ret <- rep(ret, row_cspans(obj))
    }
    ret
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "LabelRow",
  function(obj) {
    rep(list(list()), ncol(obj))
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes", "VTableTree",
  function(obj) {
    rws <- collect_leaves(obj, TRUE, TRUE)
    cells <- lapply(rws, cell_footnotes)
    do.call(rbind, cells)
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-"))

#' @export
#' @rdname int_methods
setMethod(
  "cell_footnotes<-", "CellValue",
  function(obj, value) {
    attr(obj, "footnotes") <- make_ref_value(value)
    obj
  }
)

.cfn_set_helper <- function(obj, value) {
  if (length(value) != ncol(obj)) {
    stop("Did not get the right number of footnote ref values for cell_footnotes<- on a full row.")
  }

  row_cells(obj) <- mapply(
    function(cell, fns) {
      if (is.list(fns)) {
        cell_footnotes(cell) <- lapply(fns, RefFootnote)
      } else {
        cell_footnotes(cell) <- list(RefFootnote(fns))
      }
      cell
    },
    cell = row_cells(obj),
    fns = value, SIMPLIFY = FALSE
  )
  obj
}

#' @export
#' @rdname int_methods
setMethod("cell_footnotes<-", "DataRow",
  definition = .cfn_set_helper
)

#' @export
#' @rdname int_methods
setMethod("cell_footnotes<-", "ContentRow",
  definition = .cfn_set_helper
)

# Deprecated methods ----

#' @export
#' @rdname ref_fnotes
setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))

#' @export
#' @rdname ref_fnotes
setMethod("col_fnotes_here", "ANY", function(obj) {
  lifecycle::deprecate_warn(
    when = "0.6.6",
    what = "col_fnotes_here()",
    with = "col_footnotes()"
  )
  col_footnotes(obj)
})

#' @export
#' @rdname ref_fnotes
setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))

#' @export
#' @rdname int_methods
setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
  lifecycle::deprecate_warn(
    when = "0.6.6",
    what = I("col_fnotes_here()<-"),
    with = I("col_footnotes()<-")
  )
  col_footnotes(obj) <- value
})

#' @export
#' @rdname ref_fnotes
setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))

#' @export
#' @rdname int_methods
setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)

#' @export
#' @rdname int_methods
setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)

#' @export
#' @rdname ref_fnotes
setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))

#' @export
#' @rdname int_methods
setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
  obj@col_footnotes <- make_ref_value(value)
  obj
})

#' @export
#' @rdname int_methods
setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
  obj@col_footnotes <- make_ref_value(value)
  obj
})

#' @export
#' @rdname int_methods
setMethod(
  "col_footnotes", "VTableTree",
  function(obj) {
    ctree <- coltree(obj)
    cols <- tree_children(ctree)
    while (all(sapply(cols, is, "LayoutColTree"))) {
      cols <- lapply(cols, tree_children)
      cols <- unlist(cols, recursive = FALSE)
    }
    all_col_fnotes <- lapply(cols, col_footnotes)
    if (is.null(unlist(all_col_fnotes))) {
      return(NULL)
    }

    return(all_col_fnotes)
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_index", function(obj) standardGeneric("ref_index"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_index", "RefFootnote",
  function(obj) obj@index
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_index<-", "RefFootnote",
  function(obj, value) {
    obj@index <- value
    obj
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_symbol", "RefFootnote",
  function(obj) obj@symbol
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_symbol<-", "RefFootnote",
  function(obj, value) {
    obj@symbol <- value
    obj
  }
)

#' @export
#' @rdname ref_fnotes
setGeneric("ref_msg", function(obj) standardGeneric("ref_msg"))

#' @export
#' @rdname int_methods
setMethod(
  "ref_msg", "RefFootnote",
  function(obj) obj@value
)

setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-"))

setMethod(
  ".fnote_set_inner<-", c("TableRow", "NULL"),
  function(ttrp, colpath, value) {
    row_footnotes(ttrp) <- value
    ttrp
  }
)

setMethod(
  ".fnote_set_inner<-", c("TableRow", "character"),
  function(ttrp, colpath, value) {
    ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE)
    cfns <- cell_footnotes(ttrp)
    cfns[[ind]] <- value
    cell_footnotes(ttrp) <- cfns
    ttrp
  }
)

setMethod(
  ".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"),
  function(ttrp, colpath, value) {
    ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value)
    coltree(ttrp) <- ctree
    ttrp
  }
)

setMethod(
  ".fnote_set_inner<-", c("VTableTree", "ANY"),
  function(ttrp, colpath, value) {
    if (labelrow_visible(ttrp) && !is.null(value)) {
      lblrw <- tt_labelrow(ttrp)
      row_footnotes(lblrw) <- value
      tt_labelrow(ttrp) <- lblrw
    } else if (NROW(content_table(ttrp)) == 1L) {
      ctbl <- content_table(ttrp)
      pth <- make_row_df(ctbl)$path[[1]]
      fnotes_at_path(ctbl, pth, colpath) <- value
      content_table(ttrp) <- ctbl
    } else {
      stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov
    }
    ttrp
  }
)

#' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should
#'   go on the column rather than cell.
#' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go
#'   on the row rather than cell.
#' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately
#'   recalculated. Defaults to `TRUE`.
#'
#' @examples
#' # How to add referencial footnotes after having created a table
#' lyt <- basic_table() %>%
#'   split_rows_by("SEX", page_by = TRUE) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl <- trim_rows(tbl)
#' # Check the row and col structure to add precise references
#' # row_paths(tbl)
#' # col_paths(t)
#' # row_paths_summary(tbl)
#' # col_paths_summary(tbl)
#'
#' # Add the citation numbers on the table and relative references in the footnotes
#' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1"
#' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2"
#' # tbl
#'
#' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()]
#'
#' @export
#' @rdname ref_fnotes
setGeneric("fnotes_at_path<-", function(obj,
                                        rowpath = NULL,
                                        colpath = NULL,
                                        reset_idx = TRUE,
                                        value) {
  standardGeneric("fnotes_at_path<-")
})

## non-null rowpath, null or non-null colpath
#' @inheritParams fnotes_at_path<-
#'
#' @export
#' @rdname int_methods
setMethod(
  "fnotes_at_path<-", c("VTableTree", "character"),
  function(obj,
           rowpath = NULL,
           colpath = NULL,
           reset_idx = TRUE,
           value) {
    rw <- tt_at_path(obj, rowpath)
    .fnote_set_inner(rw, colpath) <- value
    tt_at_path(obj, rowpath) <- rw
    if (reset_idx) {
      obj <- update_ref_indexing(obj)
    }
    obj
  }
)

#' @export
#' @rdname int_methods
setMethod(
  "fnotes_at_path<-", c("VTableTree", "NULL"),
  function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) {
    cinfo <- col_info(obj)
    .fnote_set_inner(cinfo, colpath) <- value
    col_info(obj) <- cinfo
    if (reset_idx) {
      obj <- update_ref_indexing(obj)
    }
    obj
  }
)

setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag"))

setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))

setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))

setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE)

setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix"))

setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix)

setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix)

setMethod("ptitle_prefix", "ANY", function(obj) NULL)

setMethod("page_titles", "VTableTree", function(obj) obj@page_titles)

setMethod("page_titles<-", "VTableTree", function(obj, value) {
  obj@page_titles <- value
  obj
})

## Horizontal separator --------------------------------------------------------

#' Access or recursively set header-body separator for tables
#'
#' @inheritParams gen_args
#' @param value (`string`)\cr string to use as new header/body separator.
#'
#' @return
#' * `horizontal_sep` returns the string acting as the header separator.
#' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its
#'   subtables.
#'
#' @export
setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))

#' @rdname horizontal_sep
#' @export
setMethod(
  "horizontal_sep", "VTableTree",
  function(obj) obj@horizontal_sep
)

#' @rdname horizontal_sep
#' @export
setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))

#' @rdname horizontal_sep
#' @export
setMethod(
  "horizontal_sep<-", "VTableTree",
  function(obj, value) {
    cont <- content_table(obj)
    if (NROW(cont) > 0) {
      horizontal_sep(cont) <- value
      content_table(obj) <- cont
    }

    kids <- lapply(tree_children(obj),
      `horizontal_sep<-`,
      value = value
    )

    tree_children(obj) <- kids
    obj@horizontal_sep <- value
    obj
  }
)

#' @rdname horizontal_sep
#' @export
setMethod(
  "horizontal_sep<-", "TableRow",
  function(obj, value) obj
)

## Section dividers ------------------------------------------------------------

# Used for splits
setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div"))

setMethod(
  "spl_section_div", "Split",
  function(obj) obj@child_section_div
)

setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-"))

setMethod(
  "spl_section_div<-", "Split",
  function(obj, value) {
    obj@child_section_div <- value
    obj
  }
)

# Used for table object parts
setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div"))
setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div)
setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div)
setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div)

setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-"))
setMethod("trailing_section_div<-", "VTableTree", function(obj, value) {
  obj@trailing_section_div <- value
  obj
})
setMethod("trailing_section_div<-", "LabelRow", function(obj, value) {
  obj@trailing_section_div <- value
  obj
})
setMethod("trailing_section_div<-", "TableRow", function(obj, value) {
  obj@trailing_section_div <- value
  obj
})

#' Section dividers accessor and setter
#'
#' `section_div` can be used to set or get the section divider for a table object
#' produced by [build_table()]. When assigned in post-processing (`section_div<-`)
#' the table can have a section divider after every row, each assigned independently.
#' If assigning during layout creation, only [split_rows_by()] (and its related row-wise
#' splits) and [analyze()] have a `section_div` parameter that will produce separators
#' between split sections and data subgroups, respectively.
#'
#' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree`
#'   or `TableRow`/`LabelRow`.
#' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows
#'   you to set the section divider only for sections that are splits or analyses if the number of
#'   values is less than the number of rows in the table. If `TRUE`, the section divider will
#'   be set for all rows of the table.
#' @param value (`character`)\cr vector of single characters to use as section dividers. Each character
#'   is repeated such that all section dividers span the width of the table. Each character that is
#'   not `NA_character_` will produce a trailing separator for each row of the table. `value` length
#'   should reflect the number of rows, or be between 1 and the number of splits/levels.
#'   See the Details section below for more information.
#'
#' @return The section divider string. Each line that does not have a trailing separator
#'   will have `NA_character_` as section divider.
#'
#' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global
#'   section dividers.
#'
#' @details
#' Assigned value to section divider must be a character vector. If any value is `NA_character_`
#' the section divider will be absent for that row or section. When you want to only affect sections
#' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows.
#' Ideally, the length of the vector should be less than the number of splits with, eventually, the
#' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted,
#' only the first split will be affected.
#' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table
#' construction, the section divider will be set for all the splits and eventually analyses, but
#' not for the header or each row of the table. This can be set with `header_section_div` in
#' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section
#' divider will be set for all the rows of the table.
#'
#' @examples
#' # Data
#' df <- data.frame(
#'   cat = c(
#'     "really long thing its so ", "long"
#'   ),
#'   value = c(6, 3, 10, 1)
#' )
#' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2)
#'
#' tbl <- basic_table() %>%
#'   split_rows_by("cat", section_div = "~") %>%
#'   analyze("value", afun = fast_afun, section_div = " ") %>%
#'   build_table(df)
#'
#' # Getter
#' section_div(tbl)
#'
#' # Setter
#' section_div(tbl) <- letters[seq_len(nrow(tbl))]
#' tbl
#'
#' # last letter can appear if there is another table
#' rbind(tbl, tbl)
#'
#' # header_section_div
#' header_section_div(tbl) <- "+"
#' tbl
#'
#' @docType methods
#' @rdname section_div
#' @export
setGeneric("section_div", function(obj) standardGeneric("section_div"))

#' @rdname section_div
#' @aliases section_div,VTableTree-method
setMethod("section_div", "VTableTree", function(obj) {
  content_row_tbl <- content_table(obj)
  is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL
  if (labelrow_visible(obj) || is_content_table) {
    section_div <- trailing_section_div(obj)
    labelrow_div <- trailing_section_div(tt_labelrow(obj))
    rest_of_tree <- section_div(tree_children(obj))
    # Case it is the section itself and not the labels to have a trailing sep
    if (!is.na(section_div)) {
      rest_of_tree[length(rest_of_tree)] <- section_div
    }
    unname(c(labelrow_div, rest_of_tree))
  } else {
    unname(section_div(tree_children(obj)))
  }
})

#' @rdname section_div
#' @aliases section_div,list-method
setMethod("section_div", "list", function(obj) {
  unlist(lapply(obj, section_div))
})

#' @rdname section_div
#' @aliases section_div,TableRow-method
setMethod("section_div", "TableRow", function(obj) {
  trailing_section_div(obj)
})

# section_div setter from table object
#' @rdname section_div
#' @export
setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) {
  standardGeneric("section_div<-")
})

#' @rdname section_div
#' @aliases section_div<-,VTableTree-method
setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) {
  char_v <- as.character(value)
  tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1)))
  max_tree_depth <- max(tree_depths)
  stopifnot(is.logical(only_sep_sections))
  .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj))

  # Automatic establishment of intent
  if (length(char_v) < nrow(obj)) {
    only_sep_sections <- TRUE
  }

  # Case where only separators or splits need to change externally
  if (only_sep_sections && length(char_v) < nrow(obj)) {
    # Case where char_v is longer than the max depth
    char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))]
    # Filling up with NAs the rest of the tree depth section div chr vector
    missing_char_v_len <- max_tree_depth - length(char_v)
    char_v <- c(char_v, rep(NA_character_, missing_char_v_len))
  }

  # Retrieving if it is a contentRow (no need for labelrow to be visible in this case)
  content_row_tbl <- content_table(obj)
  is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0

  # Main table structure change
  if (labelrow_visible(obj) || is_content_table) {
    if (only_sep_sections) {
      # Only tables are modified
      trailing_section_div(tt_labelrow(obj)) <- NA_character_
      trailing_section_div(obj) <- char_v[1]
      section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]
    } else {
      # All leaves are modified
      trailing_section_div(tt_labelrow(obj)) <- char_v[1]
      trailing_section_div(obj) <- NA_character_
      section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]
    }
  } else {
    section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v
  }
  obj
})

#' @rdname section_div
#' @aliases section_div<-,list-method
setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) {
  char_v <- as.character(value)
  for (i in seq_along(obj)) {
    stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow"))
    list_element_size <- nrow(obj[[i]])
    if (only_sep_sections) {
      char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))]
      char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i)))
    } else {
      init <- (i - 1) * list_element_size + 1
      chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1)
      char_v_i <- char_v[chunk_of_char_v_to_take]
    }
    section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i
  }
  obj
})

#' @rdname section_div
#' @aliases section_div<-,TableRow-method
setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) {
  trailing_section_div(obj) <- value
  obj
})

#' @rdname section_div
#' @aliases section_div<-,LabelRow-method
setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) {
  trailing_section_div(obj) <- value
  obj
})

# Helper check function
.check_char_vector_for_section_div <- function(char_v, min_splits, max) {
  lcv <- length(char_v)
  if (lcv < 1 || lcv > max) {
    stop("section_div must be a vector of length between 1 and numer of table rows.")
  }
  if (lcv > min_splits && lcv < max) {
    warning(
      "section_div will be truncated to the number of splits (", min_splits, ")",
      " because it is shorter than the number of rows (", max, ")."
    )
  }
  nchar_check_v <- nchar(char_v)
  if (any(nchar_check_v > 1, na.rm = TRUE)) {
    stop("section_div must be a vector of single characters or NAs")
  }
}

#' @rdname section_div
#' @export
setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))

#' @rdname section_div
#' @aliases header_section_div,PreDataTableLayouts-method
setMethod(
  "header_section_div", "PreDataTableLayouts",
  function(obj) obj@header_section_div
)

#' @rdname section_div
#' @aliases header_section_div,PreDataTableLayouts-method
setMethod(
  "header_section_div", "VTableTree",
  function(obj) obj@header_section_div
)

#' @rdname section_div
#' @export
setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))

#' @rdname section_div
#' @aliases header_section_div<-,PreDataTableLayouts-method
setMethod(
  "header_section_div<-", "PreDataTableLayouts",
  function(obj, value) {
    .check_header_section_div(value)
    obj@header_section_div <- value
    obj
  }
)

#' @rdname section_div
#' @aliases header_section_div<-,PreDataTableLayouts-method
setMethod(
  "header_section_div<-", "VTableTree",
  function(obj, value) {
    .check_header_section_div(value)
    obj@header_section_div <- value
    obj
  }
)

.check_header_section_div <- function(chr) {
  if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) {
    stop("header_section_div must be a single character or NA_character_ if not used")
  }
  invisible(TRUE)
}

#' @rdname section_div
#' @export
setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div"))

#' @rdname section_div
#' @aliases top_level_section_div,PreDataTableLayouts-method
setMethod(
  "top_level_section_div", "PreDataTableLayouts",
  function(obj) obj@top_level_section_div
)

#' @rdname section_div
#' @export
setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-"))

#' @rdname section_div
#' @aliases top_level_section_div<-,PreDataTableLayouts-method
setMethod(
  "top_level_section_div<-", "PreDataTableLayouts",
  function(obj, value) {
    checkmate::assert_character(value, len = 1, n.chars = 1)
    obj@top_level_section_div <- value
    obj
  }
)

## table_inset ----------------------------------------------------------

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset", "VTableNodeInfo", ## VTableTree",
  function(obj) obj@table_inset
)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset", "PreDataTableLayouts",
  function(obj) obj@table_inset
)

## #' @rdname formatters_methods
## #' @export
## setMethod("table_inset", "InstantiatedColumnInfo",
##           function(obj) obj@table_inset)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset<-", "VTableNodeInfo", ## "VTableTree",
  function(obj, value) {
    if (!is.integer(value)) {
      value <- as.integer(value)
    }
    if (is.na(value) || value < 0) {
      stop("Got invalid table_inset value, must be an integer > 0")
    }
    cont <- content_table(obj)
    if (NROW(cont) > 0) {
      table_inset(cont) <- value
      content_table(obj) <- cont
    }

    if (length(tree_children(obj)) > 0) {
      kids <- lapply(tree_children(obj),
        `table_inset<-`,
        value = value
      )
      tree_children(obj) <- kids
    }
    obj@table_inset <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset<-", "PreDataTableLayouts",
  function(obj, value) {
    if (!is.integer(value)) {
      value <- as.integer(value)
    }
    if (is.na(value) || value < 0) {
      stop("Got invalid table_inset value, must be an integer > 0")
    }

    obj@table_inset <- value
    obj
  }
)

#' @rdname formatters_methods
#' @export
setMethod(
  "table_inset<-", "InstantiatedColumnInfo",
  function(obj, value) {
    if (!is.integer(value)) {
      value <- as.integer(value)
    }
    if (is.na(value) || value < 0) {
      stop("Got invalid table_inset value, must be an integer > 0")
    }
    obj@table_inset <- value
    obj
  }
)

## Split types -----------------------------------------------------------------
## variable: split on distinct values of a variable
## all: include all observations (root 'split')
## rawcut: cut on static values of a variable
## quantilecut: cut on quantiles of observed values for a variable
## missing: split obs based on missingness of a variable/observation. This could be used for compare to ref_group??
## multicolumn: each child analyzes a different column
## arbitrary: children are not related to each other in any systematic fashion.

## null is ok here.
check_ok_label <- function(lbl, multi_ok = FALSE) {
  if (length(lbl) == 0) {
    return(TRUE)
  }

  if (length(lbl) > 1) {
    if (multi_ok) {
      return(all(vapply(lbl, check_ok_label, TRUE)))
    }
    stop("got a label of length > 1")
  }

  if (grepl("([{}])", lbl)) {
    stop("Labels cannot contain { or } due to their use for indicating referential footnotes")
  }
  invisible(TRUE)
}

valid_lbl_pos <- c("default", "visible", "hidden", "topleft")
.labelkids_helper <- function(charval) {
  ret <- switch(charval,
    "default" = NA,
    "visible" = TRUE,
    "hidden" = FALSE,
    "topleft" = FALSE,
    stop(
      "unrecognized charval in .labelkids_helper. ",
      "this shouldn't ever happen"
    )
  )
  ret
}

setOldClass("expression")
setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric"))

setClassUnion("integerOrNULL", c("NULL", "integer"))
setClassUnion("characterOrNULL", c("NULL", "character"))

## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame?
setClass("TreePos", representation(
  splits = "list",
  s_values = "list",
  sval_labels = "character",
  subset = "SubsetDef"
),
validity = function(object) {
  nspl <- length(object@splits)
  length(object@s_values) == nspl && length(object@sval_labels) == nspl
}
)

setClassUnion("functionOrNULL", c("NULL", "function"))
setClassUnion("listOrNULL", c("NULL", "list"))
## TODO (?) make "list" more specific, e.g FormatList, or FunctionList?
setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
setClassUnion("ExprOrNULL", c("NULL", "expression"))

setClass("ValueWrapper", representation(
  value = "ANY",
  label = "characterOrNULL",
  subset_expression = "ExprOrNULL"
),
contains = "VIRTUAL"
)
## heavier-weight than I'd like but I think we need
## this to carry around thee subsets for
## comparison-based splits

setClass("SplitValue",
  contains = "ValueWrapper",
  representation(extra = "list")
)

SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
  if (is(val, "SplitValue")) {
    if (length(splv_extra(val)) > 0) {
      extr <- c(splv_extra(val), extr)
    }
    splv_extra(val) <- extr
    return(val)
  }
  if (!is(extr, "list")) {
    extr <- list(extr)
  }
  if (!is(label, "character")) {
    label <- as.character(label)
  }

  if (!is.null(sub_expr) && !is.expression(sub_expr)) {
    sub_expr <- as.expression(sub_expr)
  } ## sometimes they will be "call" objects, etc
  check_ok_label(label)
  new("SplitValue",
    value = val,
    extra = extr,
    label = label,
    subset_expression = sub_expr
  )
}

setClass("LevelComboSplitValue",
  contains = "SplitValue",
  representation(combolevels = "character")
)

## wrapped in user-facing `add_combo_facet`
LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
  check_ok_label(label)
  new("LevelComboSplitValue",
    value = val,
    extra = extr,
    combolevels = combolevels,
    label = label,
    subset_expression = sub_expr
  )
}

setClass("Split",
  contains = "VIRTUAL",
  representation(
    payload = "ANY",
    name = "character",
    split_label = "character",
    split_format = "FormatSpec",
    split_na_str = "character",
    split_label_position = "character",
    ## NB this is the function which is applied to
    ## get the content rows for the CHILDREN of this
    ## split!!!
    content_fun = "listOrNULL", ## functionOrNULL",
    content_format = "FormatSpec",
    content_na_str = "character",
    content_var = "character",
    label_children = "logical",
    extra_args = "list",
    indent_modifier = "integer",
    content_indent_modifier = "integer",
    content_extra_args = "list",
    page_title_prefix = "character",
    child_section_div = "character",
    child_show_colcounts = "logical",
    child_colcount_format = "FormatSpec"
  )
)

setClass("CustomizableSplit",
  contains = "Split",
  representation(split_fun = "functionOrNULL")
)

#' @author Gabriel Becker
#' @exportClass VarLevelSplit
#' @rdname VarLevelSplit
setClass("VarLevelSplit",
  contains = "CustomizableSplit",
  representation(
    value_label_var = "character",
    value_order = "ANY"
  )
)
#' Split on levels within a variable
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @return a `VarLevelSplit` object.
#'
#' @export
VarLevelSplit <- function(var,
                          split_label,
                          labels_var = NULL,
                          cfun = NULL,
                          cformat = NULL,
                          cna_str = NA_character_,
                          split_fun = NULL,
                          split_format = NULL,
                          split_na_str = NA_character_,
                          valorder = NULL,
                          split_name = var,
                          child_labels = c("default", "visible", "hidden"),
                          extra_args = list(),
                          indent_mod = 0L,
                          label_pos = c("topleft", "hidden", "visible"),
                          cindent_mod = 0L,
                          cvar = "",
                          cextra_args = list(),
                          page_prefix = NA_character_,
                          section_div = NA_character_,
                          show_colcounts = FALSE,
                          colcount_format = NULL) {
  child_labels <- match.arg(child_labels)
  if (is.null(labels_var)) {
    labels_var <- var
  }
  check_ok_label(split_label)
  new("VarLevelSplit",
    payload = var,
    split_label = split_label,
    name = split_name,
    value_label_var = labels_var,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_fun = split_fun,
    split_format = split_format,
    split_na_str = split_na_str,
    value_order = NULL,
    label_children = .labelkids_helper(child_labels),
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

setClass("AllSplit", contains = "Split")

AllSplit <- function(split_label = "",
                     cfun = NULL,
                     cformat = NULL,
                     cna_str = NA_character_,
                     split_format = NULL,
                     split_na_str = NA_character_,
                     split_name = NULL,
                     extra_args = list(),
                     indent_mod = 0L,
                     cindent_mod = 0L,
                     cvar = "",
                     cextra_args = list(),
                     show_colcounts = FALSE,
                     colcount_format = NULL,
                     ...) {
  if (is.null(split_name)) {
    if (nzchar(split_label)) {
      split_name <- split_label
    } else {
      split_name <- "all obs"
    }
  }
  check_ok_label(split_label)
  new("AllSplit",
    split_label = split_label,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = "hidden",
    content_extra_args = cextra_args,
    page_title_prefix = NA_character_,
    child_section_div = NA_character_,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

setClass("RootSplit", contains = "AllSplit")

RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "",
                      split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) {
  check_ok_label(split_label)
  new("RootSplit",
    split_label = split_label,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = "root",
    label_children = FALSE,
    indent_modifier = 0L,
    content_indent_modifier = 0L,
    content_var = cvar,
    split_label_position = "hidden",
    content_extra_args = cextra_args,
    child_section_div = NA_character_,
    child_show_colcounts = FALSE,
    child_colcount_format = "(N=xx)"
  )
}

setClass("ManualSplit",
  contains = "AllSplit",
  representation(levels = "character")
)

#' Manually defined split
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#' @inheritParams gen_args
#' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split).
#'
#' @return A `ManualSplit` object.
#'
#' @author Gabriel Becker
#' @export
ManualSplit <- function(levels, label, name = "manual",
                        extra_args = list(),
                        indent_mod = 0L,
                        cindent_mod = 0L,
                        cvar = "",
                        cextra_args = list(),
                        label_pos = "visible",
                        page_prefix = NA_character_,
                        section_div = NA_character_) {
  label_pos <- match.arg(label_pos, label_pos_values)
  check_ok_label(label, multi_ok = TRUE)
  new("ManualSplit",
    split_label = label,
    levels = levels,
    name = name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = 0L,
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_format = NULL,
    split_na_str = NA_character_,
    split_label_position = label_pos,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = FALSE,
    child_colcount_format = "(N=xx)"
  )
}

## splits across which variables are being analynzed
setClass("MultiVarSplit",
  contains = "CustomizableSplit", ## "Split",
  representation(
    var_labels = "character",
    var_names = "character"
  ),
  validity = function(object) {
    length(object@payload) >= 1 &&
      all(!is.na(object@payload)) &&
      (length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels))
  }
)

.make_suffix_vec <- function(n) {
  c(
    "",
    sprintf(
      "._[[%d]]_.",
      seq_len(n - 1) + 1L
    )
  )
}

.make_multivar_names <- function(vars) {
  dups <- duplicated(vars)
  if (!any(dups)) {
    return(vars)
  }
  dupvars <- unique(vars[dups])
  ret <- vars
  for (v in dupvars) {
    pos <- which(ret == v)
    ret[pos] <- paste0(
      ret[pos],
      .make_suffix_vec(length(pos))
    )
  }
  ret
}

#' Split between two or more different variables
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @return A `MultiVarSplit` object.
#'
#' @author Gabriel Becker
#' @export
MultiVarSplit <- function(vars,
                          split_label = "",
                          varlabels = NULL,
                          varnames = NULL,
                          cfun = NULL,
                          cformat = NULL,
                          cna_str = NA_character_,
                          split_format = NULL,
                          split_na_str = NA_character_,
                          split_name = "multivars",
                          child_labels = c("default", "visible", "hidden"),
                          extra_args = list(),
                          indent_mod = 0L,
                          cindent_mod = 0L,
                          cvar = "",
                          cextra_args = list(),
                          label_pos = "visible",
                          split_fun = NULL,
                          page_prefix = NA_character_,
                          section_div = NA_character_,
                          show_colcounts = FALSE,
                          colcount_format = NULL) {
  check_ok_label(split_label)
  ## no topleft allowed
  label_pos <- match.arg(label_pos, label_pos_values[-3])
  child_labels <- match.arg(child_labels)
  if (length(vars) == 1 && grepl(":", vars)) {
    vars <- strsplit(vars, ":")[[1]]
  }
  if (length(varlabels) == 0) { ## covers NULL and character()
    varlabels <- vars
  }
  vnames <- varnames %||% .make_multivar_names(vars)
  stopifnot(length(vnames) == length(vars))
  new("MultiVarSplit",
    payload = vars,
    split_label = split_label,
    var_labels = varlabels,
    var_names = vnames,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    label_children = .labelkids_helper(child_labels),
    name = split_name,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    split_fun = split_fun,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

#' Splits for cutting by values of a numeric variable
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @exportClass VarStaticCutSplit
#' @rdname cutsplits
setClass("VarStaticCutSplit",
  contains = "Split",
  representation(
    cuts = "numeric",
    cut_labels = "character"
  )
)

.is_cut_lab_lst <- function(cuts) {
  is.list(cuts) && is.numeric(cuts[[1]]) &&
    is.character(cuts[[2]]) &&
    length(cuts[[1]]) == length(cuts[[2]])
}

#' Create static cut or static cumulative cut split
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit`
#'   object for [VarDynCutSplit()].
#'
#' @rdname cutsplits
make_static_cut_split <- function(var,
                                  split_label,
                                  cuts,
                                  cutlabels = NULL,
                                  cfun = NULL,
                                  cformat = NULL,
                                  cna_str = NA_character_,
                                  split_format = NULL,
                                  split_na_str = NA_character_,
                                  split_name = var,
                                  child_labels = c("default", "visible", "hidden"),
                                  extra_args = list(),
                                  indent_mod = 0L,
                                  cindent_mod = 0L,
                                  cvar = "",
                                  cextra_args = list(),
                                  label_pos = "visible",
                                  cumulative = FALSE,
                                  page_prefix = NA_character_,
                                  section_div = NA_character_,
                                  show_colcounts = FALSE,
                                  colcount_format = NULL) {
  cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit"
  check_ok_label(split_label)

  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  if (.is_cut_lab_lst(cuts)) {
    cutlabels <- cuts[[2]]
    cuts <- cuts[[1]]
  }
  if (is.unsorted(cuts, strictly = TRUE)) {
    stop("invalid cuts vector. not sorted unique values.")
  }

  if (is.null(cutlabels) && !is.null(names(cuts))) {
    cutlabels <- names(cuts)[-1]
  } ## XXX is this always right?

  new(cls,
    payload = var,
    split_label = split_label,
    cuts = cuts,
    cut_labels = cutlabels,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = split_name,
    label_children = .labelkids_helper(child_labels),
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

#' @exportClass CumulativeCutSplit
#' @rdname cutsplits
setClass("CumulativeCutSplit", contains = "VarStaticCutSplit")

## make_static_cut_split with cumulative=TRUE is the constructor
## for CumulativeCutSplit

## do we want this to be a CustomizableSplit instead of
## taking cut_fun?
## cut_funct must take avector and no other arguments
## and return a named vector of cut points
#' @exportClass VarDynCutSplit
#' @rdname cutsplits
setClass("VarDynCutSplit",
  contains = "Split",
  representation(
    cut_fun = "function",
    cut_label_fun = "function",
    cumulative_cuts = "logical"
  )
)

#' @export
#' @rdname cutsplits
VarDynCutSplit <- function(var,
                           split_label,
                           cutfun,
                           cutlabelfun = function(x) NULL,
                           cfun = NULL,
                           cformat = NULL,
                           cna_str = NA_character_,
                           split_format = NULL,
                           split_na_str = NA_character_,
                           split_name = var,
                           child_labels = c("default", "visible", "hidden"),
                           extra_args = list(),
                           cumulative = FALSE,
                           indent_mod = 0L,
                           cindent_mod = 0L,
                           cvar = "",
                           cextra_args = list(),
                           label_pos = "visible",
                           page_prefix = NA_character_,
                           section_div = NA_character_,
                           show_colcounts = FALSE,
                           colcount_format = NULL) {
  check_ok_label(split_label)
  label_pos <- match.arg(label_pos, label_pos_values)
  child_labels <- match.arg(child_labels)
  new("VarDynCutSplit",
    payload = var,
    split_label = split_label,
    cut_fun = cutfun,
    cumulative_cuts = cumulative,
    cut_label_fun = cutlabelfun,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    name = split_name,
    label_children = .labelkids_helper(child_labels),
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = as.integer(cindent_mod),
    content_var = cvar,
    split_label_position = label_pos,
    content_extra_args = cextra_args,
    page_title_prefix = page_prefix,
    child_section_div = section_div,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

## NB analyze splits can't have content-related things
setClass("VAnalyzeSplit",
  contains = "Split",
  representation(
    default_rowlabel = "character",
    include_NAs = "logical",
    var_label_position = "character"
  )
)

setClass("AnalyzeVarSplit",
  contains = "VAnalyzeSplit",
  representation(analysis_fun = "function")
)

setClass("AnalyzeColVarSplit",
  contains = "VAnalyzeSplit",
  representation(analysis_fun = "list")
)

#' Define a subset tabulation/analysis
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`.
#'
#' @return An `AnalyzeVarSplit` object.
#'
#' @author Gabriel Becker
#' @export
#' @rdname avarspl
AnalyzeVarSplit <- function(var,
                            split_label = var,
                            afun,
                            defrowlab = "",
                            cfun = NULL,
                            cformat = NULL,
                            split_format = NULL,
                            split_na_str = NA_character_,
                            inclNAs = FALSE,
                            split_name = var,
                            extra_args = list(),
                            indent_mod = 0L,
                            label_pos = "default",
                            cvar = "",
                            section_div = NA_character_) {
  check_ok_label(split_label)
  label_pos <- match.arg(label_pos, c("default", label_pos_values))
  if (!any(nzchar(defrowlab))) {
    defrowlab <- as.character(substitute(afun))
    if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) {
      defrowlab <- ""
    }
  }
  new("AnalyzeVarSplit",
    payload = var,
    split_label = split_label,
    content_fun = cfun,
    analysis_fun = afun,
    content_format = cformat,
    split_format = split_format,
    split_na_str = split_na_str,
    default_rowlabel = defrowlab,
    include_NAs = inclNAs,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = 0L,
    var_label_position = label_pos,
    content_var = cvar,
    page_title_prefix = NA_character_,
    child_section_div = section_div,
    child_show_colcounts = FALSE,
    child_colcount_format = NA_character_
  ) ## no content_extra_args
}

#' Define a subset tabulation/analysis
#'
#' @inheritParams lyt_args
#' @inheritParams constr_args
#'
#' @author Gabriel Becker
#' @export
#' @rdname avarspl
AnalyzeColVarSplit <- function(afun,
                               defrowlab = "",
                               cfun = NULL,
                               cformat = NULL,
                               split_format = NULL,
                               split_na_str = NA_character_,
                               inclNAs = FALSE,
                               split_name = "",
                               extra_args = list(),
                               indent_mod = 0L,
                               label_pos = "default",
                               cvar = "",
                               section_div = NA_character_) {
  label_pos <- match.arg(label_pos, c("default", label_pos_values))
  new("AnalyzeColVarSplit",
    payload = NA_character_,
    split_label = "",
    content_fun = cfun,
    analysis_fun = afun,
    content_format = cformat,
    split_format = split_format,
    split_na_str = split_na_str,
    default_rowlabel = defrowlab,
    include_NAs = inclNAs,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    indent_modifier = as.integer(indent_mod),
    content_indent_modifier = 0L,
    var_label_position = label_pos,
    content_var = cvar,
    page_title_prefix = NA_character_,
    child_section_div = section_div,
    child_show_colcounts = FALSE,
    child_colcount_format = NA_character_
  ) ## no content_extra_args
}

setClass("CompoundSplit",
  contains = "Split",
  validity = function(object) are(object@payload, "Split")
)

setClass("AnalyzeMultiVars", contains = "CompoundSplit")

.repoutlst <- function(x, nv) {
  if (!is.function(x) && length(x) == nv) {
    return(x)
  }
  if (!is(x, "list")) {
    x <- list(x)
  }
  rep(x, length.out = nv)
}

.uncompound <- function(csplit) {
  if (is(csplit, "list")) {
    return(unlist(lapply(csplit, .uncompound)))
  }

  if (!is(csplit, "CompoundSplit")) {
    return(csplit)
  }

  pld <- spl_payload(csplit)
  done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit"))
  if (done) {
    pld
  } else {
    unlist(lapply(pld, .uncompound))
  }
}

strip_compound_name <- function(obj) {
  nm <- obj_name(obj)
  gsub("^ma_", "", nm)
}

make_ma_name <- function(spl, pld = spl_payload(spl)) {
  paste(
    c(
      "ma",
      vapply(pld, strip_compound_name, "")
    ),
    collapse = "_"
  )
}

#' @param .payload (`list`)\cr used internally, not intended to be set by end users.
#'
#' @return An `AnalyzeMultiVars` split object.
#'
#' @export
#' @rdname avarspl
AnalyzeMultiVars <- function(var,
                             split_label = "",
                             afun,
                             defrowlab = "",
                             cfun = NULL,
                             cformat = NULL,
                             split_format = NULL,
                             split_na_str = NA_character_,
                             inclNAs = FALSE,
                             .payload = NULL,
                             split_name = NULL,
                             extra_args = list(),
                             indent_mod = 0L,
                             child_labels = c("default", "topleft", "visible", "hidden"),
                             child_names = var,
                             cvar = "",
                             section_div = NA_character_) {
  ## NB we used to resolve to strict TRUE/FALSE for label visibillity
  ## in this function but that was too greedy for repeated
  ## analyze calls, so that now occurs in the tabulation machinery
  ## when the table is actually being built.
  ##  show_kidlabs = .labelkids_helper(match.arg(child_labels))
  child_labels <- match.arg(child_labels)
  show_kidlabs <- child_labels
  if (is.null(.payload)) {
    nv <- length(var)
    defrowlab <- .repoutlst(defrowlab, nv)
    afun <- .repoutlst(afun, nv)
    split_label <- .repoutlst(split_label, nv)
    check_ok_label(split_label, multi_ok = TRUE)
    cfun <- .repoutlst(cfun, nv)
    cformat <- .repoutlst(cformat, nv)
    ##        split_format = .repoutlst(split_format, nv)
    inclNAs <- .repoutlst(inclNAs, nv)
    section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div
    pld <- mapply(AnalyzeVarSplit,
      var = var,
      split_name = child_names,
      split_label = split_label,
      afun = afun,
      defrowlab = defrowlab,
      cfun = cfun,
      cformat = cformat,
      ##                     split_format = split_format,
      inclNAs = inclNAs,
      MoreArgs = list(
        extra_args = extra_args,
        indent_mod = indent_mod,
        label_pos = show_kidlabs,
        split_format = split_format,
        split_na_str = split_na_str,
        section_div = section_div_if_multivar
      ), ## rvis),
      SIMPLIFY = FALSE
    )
  } else {
    ## we're combining existing splits here
    pld <- unlist(lapply(.payload, .uncompound))

    ## only override the childen being combined if the constructor
    ## was passed a non-default value for child_labels
    ## and the child was at NA before
    pld <- lapply(
      pld,
      function(x) {
        rvis <- label_position(x) ## labelrow_visible(x)
        if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) {
          if (identical(rvis, "default")) { ## ois.na(rvis))
            rvis <- show_kidlabs
          }
        }
        label_position(x) <- rvis
        x
      }
    )
  }
  if (length(pld) == 1) {
    ret <- pld[[1]]
  } else {
    if (is.null(split_name)) {
      split_name <- paste(c("ma", vapply(pld, obj_name, "")),
        collapse = "_"
      )
    }
    ret <- new("AnalyzeMultiVars",
      payload = pld,
      split_label = "",
      split_format = NULL,
      split_na_str = split_na_str,
      content_fun = NULL,
      content_format = NULL,
      ## I beleive this is superfluous now
      ## the payloads carry aroudn the real instructions
      ## XXX
      label_children = .labelkids_helper(show_kidlabs),
      split_label_position = "hidden", ## XXX is this right?
      name = split_name,
      extra_args = extra_args,
      ## modifier applied on splits in payload
      indent_modifier = 0L,
      content_indent_modifier = 0L,
      content_var = cvar,
      page_title_prefix = NA_character_,
      child_section_div = section_div
    )
  }
  ret
}

setClass("VarLevWBaselineSplit",
  contains = "VarLevelSplit",
  representation(
    var = "character",
    ref_group_value = "character"
  )
)

#' @rdname VarLevelSplit
#' @export
VarLevWBaselineSplit <- function(var,
                                 ref_group,
                                 labels_var = var,
                                 split_label,
                                 split_fun = NULL,
                                 label_fstr = "%s - %s",
                                 ## not needed I Think...
                                 cfun = NULL,
                                 cformat = NULL,
                                 cna_str = NA_character_,
                                 cvar = "",
                                 split_format = NULL,
                                 split_na_str = NA_character_,
                                 valorder = NULL,
                                 split_name = var,
                                 extra_args = list(),
                                 show_colcounts = FALSE,
                                 colcount_format = NULL) {
  check_ok_label(split_label)
  new("VarLevWBaselineSplit",
    payload = var,
    ref_group_value = ref_group,
    ## This will occur at the row level not on the column split, for now
    ## TODO revisit this to confirm its right
    ##        comparison_func = comparison,
    #      label_format = label_fstr,
    value_label_var = labels_var,
    split_label = split_label,
    content_fun = cfun,
    content_format = cformat,
    content_na_str = cna_str,
    split_format = split_format,
    split_na_str = split_na_str,
    split_fun = split_fun,
    name = split_name,
    label_children = FALSE,
    extra_args = extra_args,
    ## this is always a column split
    indent_modifier = 0L,
    content_indent_modifier = 0L,
    content_var = cvar,
    ## so long as this is columnspace only
    page_title_prefix = NA_character_,
    child_section_div = NA_character_,
    child_show_colcounts = show_colcounts,
    child_colcount_format = colcount_format
  )
}

.chkname <- function(nm) {
  if (is.null(nm)) {
    nm <- ""
  }
  if (length(nm) != 1) {
    stop("name is not of length one")
  } else if (is.na(nm)) {
    warning("Got missing value for name, converting to characters '<NA>'")
    nm <- "<NA>"
  }
  nm
}

### Tree Position Representation
###
### Class(es) that represent position with in a
### tree as parallel vectors of Split objects and
### values chosen at that split, plus labeling info
TreePos <- function(spls = list(),
                    svals = list(),
                    svlabels = character(),
                    sub = NULL) {
  check_ok_label(svlabels, multi_ok = TRUE)
  svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr))
  if (is.null(sub)) {
    if (length(spls) > 0) {
      sub <- make_pos_subset(
        spls = spls,
        svals = svals
      )
    } else {
      sub <- expression(TRUE)
    }
  }
  new("TreePos",
    splits = spls, s_values = svals,
    sval_labels = svlabels,
    subset = sub
  )
}

## Tree position convenience functions
##
make_child_pos <- function(parpos,
                           newspl,
                           newval,
                           newlab = newval,
                           newextra = list()) {
  if (!is(newval, "SplitValue")) {
    nsplitval <- SplitValue(newval, extr = newextra, label = newlab)
  } else {
    nsplitval <- newval
  }
  check_ok_label(newlab)
  newpos <- TreePos(
    spls = c(pos_splits(parpos), newspl),
    svals = c(pos_splvals(parpos), nsplitval),
    svlabels = c(pos_splval_labels(parpos), newlab),
    sub = .combine_subset_exprs(
      pos_subset(parpos),
      ## this will grab the value's custom subset expression if present
      make_subset_expr(newspl, nsplitval)
    )
  )
  newpos
}

## Virtual Classes for Tree Nodes and Layouts =================================
##
## Virtual class hiearchy for the various types of trees in use in the S4
## implementation of the TableTree machinery

## core basics
setClass("VNodeInfo",
  contains = "VIRTUAL",
  representation(
    level = "integer",
    name = "character" ## ,
    ## label = "character"
  )
)

setClass("VTree",
  contains = c("VIRTUAL", "VNodeInfo"),
  representation(children = "list")
)

setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo"))

## Layout trees =================================

# setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo"))

setClass("VLayoutLeaf",
  contains = c("VIRTUAL", "VLeaf"),
  representation(
    pos_in_tree = "TreePos",
    label = "character"
  )
)

setClass("VLayoutTree",
  contains = c("VIRTUAL", "VTree"),
  representation(
    split = "Split",
    pos_in_tree = "TreePos",
    label = "character"
  )
)

setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree"))

## LayoutAxisTree classes =================================

setOldClass("function")
setOldClass("NULL")
setClassUnion("FunctionOrNULL", c("function", "NULL"))

setClass("LayoutAxisTree",
  contains = "VLayoutTree",
  representation(summary_func = "FunctionOrNULL"),
  validity = function(object) {
    all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf")))
  }
)

## this is only used for columns!!!!
setClass("LayoutAxisLeaf",
  contains = "VLayoutLeaf", ## "VNodeInfo",
  representation(
    func = "function",
    display_columncounts = "logical",
    columncount_format = "FormatSpec", # character",
    col_footnotes = "list",
    column_count = "integer"
  )
)

setClass("LayoutColTree",
  contains = "LayoutAxisTree",
  representation(
    display_columncounts = "logical",
    columncount_format = "FormatSpec", # "character",
    col_footnotes = "list",
    column_count = "integer"
  )
)

setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
LayoutColTree <- function(lev = 0L,
                          name = obj_name(spl),
                          label = obj_label(spl),
                          kids = list(),
                          spl = EmptyAllSplit,
                          tpos = TreePos(),
                          summary_function = NULL,
                          disp_ccounts = FALSE,
                          colcount_format = NULL,
                          footnotes = list(),
                          colcount) { ## ,
  ## sub = expression(TRUE),
  ## svar = NA_character_,
  ## slab = NA_character_) {
  if (is.null(spl)) {
    stop(
      "LayoutColTree constructor got NULL for spl. ", # nocov
      "This should never happen. Please contact the maintainer."
    )
  } # nocov
  footnotes <- make_ref_value(footnotes)
  check_ok_label(label)
  new("LayoutColTree",
    level = lev, children = kids,
    name = .chkname(name),
    summary_func = summary_function,
    pos_in_tree = tpos,
    split = spl,
    ## subset = sub,
    ## splitvar = svar,
    label = label,
    display_columncounts = disp_ccounts,
    columncount_format = colcount_format,
    col_footnotes = footnotes,
    column_count = colcount
  )
}

LayoutColLeaf <- function(lev = 0L,
                          name = label,
                          label = "",
                          tpos = TreePos(),
                          colcount,
                          disp_ccounts = FALSE,
                          colcount_format = NULL) {
  check_ok_label(label)
  new("LayoutColLeaf",
    level = lev, name = .chkname(name), label = label,
    pos_in_tree = tpos,
    column_count = colcount,
    display_columncounts = disp_ccounts,
    columncount_format = colcount_format
  )
}

## Instantiated column info class ==============================================
##
## This is so we don't need multiple arguments
## in the recursive functions that track
## various aspects of the column layout
## once its applied to the data.

#' Instantiated column info
#'
#' @inheritParams gen_args
#'
#' @exportClass InstantiatedColumnInfo
#' @rdname cinfo
setClass(
  "InstantiatedColumnInfo",
  representation(
    tree_layout = "VLayoutNode", ## LayoutColTree",
    subset_exprs = "list",
    cextra_args = "list",
    counts = "integer",
    total_count = "integer",
    display_columncounts = "logical",
    columncount_format = "FormatSpec",
    columncount_na_str = "character",
    top_left = "character"
  )
)

#' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object.
#' @param csubs (`list`)\cr a list of subsetting expressions.
#' @param extras (`list`)\cr extra arguments associated with the columns.
#' @param cnts (`integer`)\cr counts.
#' @param total_cnt (`integer(1)`)\cr total observations represented across all columns.
#' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated
#'   table is printed.
#' @param countformat (`string`)\cr format for the counts if they are displayed.
#' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults
#'   to `""`.
#'
#' @return An `InstantiateadColumnInfo` object.
#'
#' @export
#' @rdname cinfo
InstantiatedColumnInfo <- function(treelyt = LayoutColTree(colcount = total_cnt),
                                   csubs = list(expression(TRUE)),
                                   extras = list(list()),
                                   cnts = NA_integer_,
                                   total_cnt = NA_integer_,
                                   dispcounts = FALSE,
                                   countformat = "(N=xx)",
                                   count_na_str = "",
                                   topleft = character()) {
  leaves <- collect_leaves(treelyt)
  nl <- length(leaves)
  extras <- rep(extras, length.out = nl)
  cnts <- rep(cnts, length.out = nl)
  csubs <- rep(csubs, length.out = nl)

  nleaves <- length(leaves)
  snas <- sum(is.na(cnts))
  if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) {
    stop(
      "Mismatching number of columns indicated by: csubs [",
      length(csubs), "], ",
      "treelyt [", nl, "], extras [", length(extras),
      "] and counts [", cnts, "]."
    )
  }
  if (snas != 0 && snas != nleaves) {
    warning(
      "Mixture of missing and non-missing column counts when ",
      "creating column info."
    )
  }

  if (!is.na(dispcounts)) {
    pths <- col_paths(treelyt)
    for (path in pths) {
      colcount_visible(treelyt, path) <- dispcounts
    }
  } else { ## na leaves the children as they are and dispcols goes to whether any of them are displayed for the leaves
    dispcounts <- any(vapply(leaves, disp_ccounts, NA))
  }

  new("InstantiatedColumnInfo",
    tree_layout = treelyt,
    subset_exprs = csubs,
    cextra_args = extras,
    counts = cnts,
    total_count = total_cnt,
    display_columncounts = dispcounts,
    columncount_format = countformat,
    columncount_na_str = count_na_str,
    top_left = topleft
  )
}

## TableTrees and row classes ==================================================
## XXX Rowspans as implemented dont really work
## they're aren't attached to the right data structures
## during conversions.

## FIXME: if we ever actually need row spanning
setClass("VTableNodeInfo",
  contains = c("VNodeInfo", "VIRTUAL"),
  representation(
    ## col_layout = "VLayoutNode",
    col_info = "InstantiatedColumnInfo",
    format = "FormatSpec",
    na_str = "character",
    indent_modifier = "integer",
    table_inset = "integer"
  )
)

setClass("TableRow",
  contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"),
  representation(
    leaf_value = "ANY",
    var_analyzed = "character",
    ##         var_label = "character",
    label = "character",
    row_footnotes = "list",
    trailing_section_div = "character"
  )
)

## TableTree Core Non-Virtual Classes ==============
##
#' Row classes and constructors
#'
#' @inheritParams constr_args
#' @inheritParams lyt_args
#' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only).
#'
#' @return A formal object representing a table row of the constructed type.
#'
#' @author Gabriel Becker
#' @export
#' @rdname rowclasses
LabelRow <- function(lev = 1L,
                     label = "",
                     name = label,
                     vis = !is.na(label) && nzchar(label),
                     cinfo = EmptyColInfo,
                     indent_mod = 0L,
                     table_inset = 0L,
                     trailing_section_div = NA_character_) {
  check_ok_label(label)
  new("LabelRow",
    leaf_value = list(),
    level = lev,
    label = label,
    ## XXX this means that a label row and its talbe can have the same name....
    ## XXX that is bad but how bad remains to be seen
    ## XXX
    name = .chkname(name),
    col_info = cinfo,
    visible = vis,
    indent_modifier = as.integer(indent_mod),
    table_inset = as.integer(table_inset),
    trailing_section_div = trailing_section_div
  )
}

#' Row constructors and classes
#'
#' @rdname rowclasses
#' @exportClass DataRow
setClass("DataRow",
  contains = "TableRow",
  representation(colspans = "integer") ## ,
  ## pos_in_tree = "TableRowPos"),
  ##      validity = function(object) {
  ## lcsp = length(object@colspans)
  ## length(lcsp ==  0) || lcsp == length(object@leaf_value)
  ## }
)

#' @rdname rowclasses
#' @exportClass ContentRow
setClass("ContentRow",
  contains = "TableRow",
  representation(colspans = "integer") ## ,
  ## pos_in_tree = "TableRowPos"),
  ##      validity = function(object) {
  ## lcsp = length(object@colspans)
  ## length(lcsp ==  0) || lcsp == length(object@leaf_value)
  ## }
)

#' @rdname rowclasses
#' @exportClass LabelRow
setClass("LabelRow",
  contains = "TableRow",
  representation(visible = "logical")
)

#' @param klass (`character`)\cr internal detail.
#'
#' @export
#' @rdname rowclasses
.tablerow <- function(vals = list(),
                      name = "",
                      lev = 1L,
                      label = name,
                      cspan = rep(1L, length(vals)),
                      cinfo = EmptyColInfo,
                      var = NA_character_,
                      format = NULL,
                      na_str = NA_character_,
                      klass,
                      indent_mod = 0L,
                      footnotes = list(),
                      table_inset = 0L,
                      trailing_section_div = NA_character_) {
  if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
    name <- label
  }
  vals <- lapply(vals, rcell)
  rlabels <- unique(unlist(lapply(vals, obj_label)))
  if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
    label <- rlabels[nzchar(rlabels)]
  }
  if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) {
    cspan <- vapply(vals, cell_cspan, 0L)
  }

  check_ok_label(label)
  rw <- new(klass,
    leaf_value = vals,
    name = .chkname(name),
    level = lev,
    label = .chkname(label),
    colspans = cspan,
    col_info = cinfo,
    var_analyzed = var,
    ## these are set in set_format_recursive below
    format = NULL,
    na_str = NA_character_,
    indent_modifier = indent_mod,
    row_footnotes = footnotes,
    table_inset = table_inset,
    trailing_section_div = trailing_section_div
  )
  rw <- set_format_recursive(rw, format, na_str, FALSE)
  rw
}

#' @param ... additional parameters passed to shared constructor (`.tablerow`).
#'
#' @export
#' @rdname rowclasses
DataRow <- function(...) .tablerow(..., klass = "DataRow")

#' @export
#' @rdname rowclasses
ContentRow <- function(...) .tablerow(..., klass = "ContentRow")

setClass("VTitleFooter",
  contains = "VIRTUAL",
  representation(
    main_title = "character",
    subtitles = "character",
    main_footer = "character",
    provenance_footer = "character"
  )
)

setClass("VTableTree",
  contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"),
  representation(
    children = "list",
    rowspans = "data.frame",
    labelrow = "LabelRow",
    page_titles = "character",
    horizontal_sep = "character",
    header_section_div = "character",
    trailing_section_div = "character"
  )
)

setClassUnion("IntegerOrNull", c("integer", "NULL"))
## covered because it's ElementaryTable's validity method but covr misses it
## nocov start
etable_validity <- function(object) {
  kids <- tree_children(object)
  all(sapply(
    kids,
    function(k) {
      (is(k, "DataRow") || is(k, "ContentRow"))
    }
  )) ###  &&
}
## nocov end

#' `TableTree` classes
#'
#' @return A formal object representing a populated table.
#'
#' @author Gabriel Becker
#' @exportClass ElementaryTable
#' @rdname tabclasses
setClass("ElementaryTable",
  contains = "VTableTree",
  representation(var_analyzed = "character"),
  validity = etable_validity ## function(object) {
)

.enforce_valid_kids <- function(lst, colinfo) {
  ## colinfo
  if (!no_colinfo(colinfo)) {
    lst <- lapply(
      lst,
      function(x) {
        if (no_colinfo(x)) {
          col_info(x) <- colinfo
        } else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) {
          ## split functions from function factories (e.g. add_combo_levels)
          ## have different environments so we can't use identical here
          ## all.equal requires the **values within the closures** to be the
          ## same but not the actual enclosing environments.
          stop(
            "attempted to add child with non-matching, non-empty ",
            "column info to an existing table"
          )
        }
        x
      }
    )
  }

  if (are(lst, "ElementaryTable") &&
    all(sapply(lst, function(tb) {
      nrow(tb) <= 1 && identical(obj_name(tb), "")
    }))) {
    lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]]))
  }
  if (length(lst) == 0) {
    return(list())
  }
  ## names
  realnames <- sapply(lst, obj_name)
  lstnames <- names(lst)
  if (is.null(lstnames)) {
    names(lst) <- realnames
  } else if (!identical(realnames, lstnames)) {
    names(lst) <- realnames
  }

  lst
}

#' Table constructors and classes
#'
#' @inheritParams constr_args
#' @inheritParams gen_args
#' @inheritParams lyt_args
#' @param rspans (`data.frame`)\cr currently stored but otherwise ignored.
#'
#' @author Gabriel Becker
#' @export
#' @rdname tabclasses
ElementaryTable <- function(kids = list(),
                            name = "",
                            lev = 1L,
                            label = "",
                            labelrow = LabelRow(
                              lev = lev,
                              label = label,
                              vis = !isTRUE(iscontent) &&
                                !is.na(label) &&
                                nzchar(label)
                            ),
                            rspans = data.frame(),
                            cinfo = NULL,
                            iscontent = NA,
                            var = NA_character_,
                            format = NULL,
                            na_str = NA_character_,
                            indent_mod = 0L,
                            title = "",
                            subtitles = character(),
                            main_footer = character(),
                            prov_footer = character(),
                            header_section_div = NA_character_,
                            hsep = default_hsep(),
                            trailing_section_div = NA_character_,
                            inset = 0L) {
  check_ok_label(label)
  if (is.null(cinfo)) {
    if (length(kids) > 0) {
      cinfo <- col_info(kids[[1]])
    } else {
      cinfo <- EmptyColInfo
    }
  }

  if (no_colinfo(labelrow)) {
    col_info(labelrow) <- cinfo
  }
  kids <- .enforce_valid_kids(kids, cinfo)
  tab <- new("ElementaryTable",
    children = kids,
    name = .chkname(name),
    level = lev,
    labelrow = labelrow,
    rowspans = rspans,
    col_info = cinfo,
    var_analyzed = var,
    ## XXX these are hardcoded, because they both get set during
    ## set_format_recursive anyway
    format = NULL,
    na_str = NA_character_,
    table_inset = 0L,
    indent_modifier = as.integer(indent_mod),
    main_title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    provenance_footer = prov_footer,
    horizontal_sep = hsep,
    header_section_div = header_section_div,
    trailing_section_div = trailing_section_div
  )
  tab <- set_format_recursive(tab, format, na_str, FALSE)
  table_inset(tab) <- as.integer(inset)
  tab
}

ttable_validity <- function(object) {
  all(sapply(
    tree_children(object),
    function(x) is(x, "VTableTree") || is(x, "TableRow")
  ))
}

.calc_cinfo <- function(cinfo, cont, kids) {
  if (!is.null(cinfo)) {
    cinfo
  } else if (!is.null(cont)) {
    col_info(cont)
  } else if (length(kids) >= 1) {
    col_info(kids[[1]])
  } else {
    EmptyColInfo
  }
}

## under this model, non-leaf nodes can have a content table where rollup
## analyses live
#' @exportClass TableTree
#' @rdname tabclasses
setClass("TableTree",
  contains = c("VTableTree"),
  representation(
    content = "ElementaryTable",
    page_title_prefix = "character"
  ),
  validity = ttable_validity
)

#' @export
#' @rdname tabclasses
TableTree <- function(kids = list(),
                      name = if (!is.na(var)) var else "",
                      cont = EmptyElTable,
                      lev = 1L,
                      label = name,
                      labelrow = LabelRow(
                        lev = lev,
                        label = label,
                        vis = nrow(cont) == 0 && !is.na(label) &&
                          nzchar(label)
                      ),
                      rspans = data.frame(),
                      iscontent = NA,
                      var = NA_character_,
                      cinfo = NULL,
                      format = NULL,
                      na_str = NA_character_,
                      indent_mod = 0L,
                      title = "",
                      subtitles = character(),
                      main_footer = character(),
                      prov_footer = character(),
                      page_title = NA_character_,
                      hsep = default_hsep(),
                      header_section_div = NA_character_,
                      trailing_section_div = NA_character_,
                      inset = 0L) {
  check_ok_label(label)
  cinfo <- .calc_cinfo(cinfo, cont, kids)

  kids <- .enforce_valid_kids(kids, cinfo)
  if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
    stop("Got table tree with content table and content position")
  }
  if (no_colinfo(labelrow)) {
    col_info(labelrow) <- cinfo
  }
  if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) {
    if (!is.na(page_title)) {
      stop("Got a page title prefix for an Elementary Table")
    }
    ## constructor takes care of recursive format application
    ElementaryTable(
      kids = kids,
      name = .chkname(name),
      lev = lev,
      labelrow = labelrow,
      rspans = rspans,
      cinfo = cinfo,
      var = var,
      format = format,
      na_str = na_str,
      indent_mod = indent_mod,
      title = title,
      subtitles = subtitles,
      main_footer = main_footer,
      prov_footer = prov_footer,
      hsep = hsep,
      header_section_div = header_section_div,
      trailing_section_div = trailing_section_div,
      inset = inset
    )
  } else {
    tab <- new("TableTree",
      content = cont,
      children = kids,
      name = .chkname(name),
      level = lev,
      labelrow = labelrow,
      rowspans = rspans,
      col_info = cinfo,
      format = NULL,
      na_str = na_str,
      table_inset = 0L,
      indent_modifier = as.integer(indent_mod),
      main_title = title,
      subtitles = subtitles,
      main_footer = main_footer,
      provenance_footer = prov_footer,
      page_title_prefix = page_title,
      horizontal_sep = "-",
      header_section_div = header_section_div,
      trailing_section_div = trailing_section_div
    ) ## this is overridden below to get recursiveness
    tab <- set_format_recursive(tab, format, na_str, FALSE)

    ## these is recursive
    ## XXX combine these probably
    horizontal_sep(tab) <- hsep
    table_inset(tab) <- as.integer(inset)
    tab
  }
}

### Pre-Data Layout Declaration Classes
###
### Notably these are NOT represented as trees
### because without data we cannot know what the
### children should be.

## Vector (ordered list) of splits.
##
## This is a vector (ordered list) of splits to be
## applied recursively to the data when provided.
##
## For convenience, if this is length 1, it can contain
## a pre-existing TableTree/ElementaryTable.
## This is used for add_existing_table in colby_constructors.R

setClass("SplitVector",
  contains = "list",
  validity = function(object) {
    if (length(object) >= 1) {
      lst <- tail(object, 1)[[1]]
    } else {
      lst <- NULL
    }
    all(sapply(head(object, -1), is, "Split")) &&
      (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo"))
  }
)

SplitVector <- function(x = NULL,
                        ...,
                        lst = list(...)) {
  if (!is.null(x)) {
    lst <- unlist(c(list(x), lst), recursive = FALSE)
  }
  new("SplitVector", lst)
}

avar_noneorlast <- function(vec) {
  if (!is(vec, "SplitVector")) {
    return(FALSE)
  }
  if (length(vec) == 0) {
    return(TRUE)
  }
  isavar <- which(sapply(vec, is, "AnalyzeVarSplit"))
  (length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec))
}

setClass("PreDataAxisLayout",
  contains = "list",
  representation(root_split = "ANY"),
  validity = function(object) {
    allleafs <- unlist(object, recursive = TRUE)
    all(sapply(object, avar_noneorlast)) &&
      all(sapply(
        allleafs,
        ## remember existing table trees can be added to layouts
        ## for now...
        function(x) is(x, "Split") || is(x, "VTableTree")
      ))
  }
)

setClass("PreDataColLayout",
  contains = "PreDataAxisLayout",
  representation(
    display_columncounts = "logical",
    columncount_format = "FormatSpec" # "character"
  )
)

setClass("PreDataRowLayout", contains = "PreDataAxisLayout")

PreDataColLayout <- function(x = SplitVector(),
                             rtsp = RootSplit(),
                             ...,
                             lst = list(x, ...),
                             disp_colcounts = NA,
                             colcount_format = "(N=xx)") {
  ret <- new("PreDataColLayout", lst,
    display_columncounts = disp_colcounts,
    columncount_format = colcount_format
  )
  ret@root_split <- rtsp
  ret
}

PreDataRowLayout <- function(x = SplitVector(),
                             root = RootSplit(),
                             ...,
                             lst = list(x, ...)) {
  new("PreDataRowLayout", lst, root_split = root)
}

setClass("PreDataTableLayouts",
  contains = "VTitleFooter",
  representation(
    row_layout = "PreDataRowLayout",
    col_layout = "PreDataColLayout",
    top_left = "character",
    header_section_div = "character",
    top_level_section_div = "character",
    table_inset = "integer"
  )
)

PreDataTableLayouts <- function(rlayout = PreDataRowLayout(),
                                clayout = PreDataColLayout(),
                                topleft = character(),
                                title = "",
                                subtitles = character(),
                                main_footer = character(),
                                prov_footer = character(),
                                header_section_div = NA_character_,
                                top_level_section_div = NA_character_,
                                table_inset = 0L) {
  new("PreDataTableLayouts",
    row_layout = rlayout,
    col_layout = clayout,
    top_left = topleft,
    main_title = title,
    subtitles = subtitles,
    main_footer = main_footer,
    provenance_footer = prov_footer,
    header_section_div = header_section_div,
    top_level_section_div = top_level_section_div,
    table_inset = table_inset
  )
}

## setClass("CellValue", contains = "ValueWrapper",
##          representation(format = "FormatSpec",
##                         colspan = "integerOrNULL",
##                         label = "characterOrNULL"),
##          prototype = list(label ="", colspan = NULL, format = NULL))

setOldClass("CellValue")

#' Length of a Cell value
#'
#' @param x (`CellValue`)\cr a `CellValue` object.
#'
#' @return Always returns `1L`.
#'
#' @exportMethod length
setMethod(
  "length", "CellValue",
  function(x) 1L
)

setClass("RefFootnote", representation(
  value = "character",
  index = "integer",
  symbol = "character"
))

RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
  if (is(note, "RefFootnote")) {
    return(note)
  } else if (length(note) == 0) {
    return(NULL)
  }
  if (length(symbol) != 1L) {
    stop(
      "Referential footnote can only have a single string as its index.",
      " Got char vector of length ", length(index)
    )
  }
  if (!is.na(symbol) && (index == "NA" || grepl("[{}]", index))) {
    stop(
      "The string 'NA' and strings containing '{' or '}' cannot be used as ",
      "referential footnote index symbols. Got string '", index, "'."
    )
  }

  new("RefFootnote", value = note, index = index, symbol = symbol)
}

#' Constructor for Cell Value
#'
#' @inheritParams lyt_args
#' @inheritParams rcell
#' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted.
#'
#' @return An object representing the value within a single cell within a populated table. The underlying structure
#'   of this object is an implementation detail and should not be relied upon beyond calling accessors for the class.
#'
#' @export

## Class definition
## [[1]] list: cell value
## format : format for cell
## colspan: column span info for cell
## label: row label to be used for parent row
## indent_mod: indent modifier to be used for parent row
CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,
                      indent_mod = NULL, footnotes = NULL,
                      align = NULL, format_na_str = NULL) {
  if (is.null(colspan)) {
    colspan <- 1L
  }
  if (!is.null(colspan) && !is(colspan, "integer")) {
    colspan <- as.integer(colspan)
  }
  ## if we're not given a label but the value has one associated with
  ## it we use that.
  ## NB: we need to be able to override a non-empty label with an empty one
  ## so we can't have "" mean "not given a label" here
  if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) {
    label <- obj_label(val)
  }
  if (!is.list(footnotes)) {
    footnotes <- lapply(footnotes, RefFootnote)
  }
  check_ok_label(label)
  ret <- structure(list(val),
    format = format, colspan = colspan,
    label = label,
    indent_mod = indent_mod, footnotes = footnotes,
    align = align,
    format_na_str = format_na_str,
    class = "CellValue"
  )
  ret
}

#' @method print CellValue
#'
#' @export
print.CellValue <- function(x, ...) {
  cat(paste("rcell:", format_rcell(x), "\n"))
  invisible(x)
}

## too slow
# setClass("RowsVerticalSection", contains = "list",
#          representation = list(row_names = "characterOrNULL",
#                                row_labels = "characterOrNULL",
#                                row_formats = "ANY",
#                                indent_mods = "integerOrNULL"))

setOldClass("RowsVerticalSection")
RowsVerticalSection <- function(values,
                                names = names(values),
                                labels = NULL,
                                indent_mods = NULL,
                                formats = NULL,
                                footnotes = NULL,
                                format_na_strs = NULL) {
  stopifnot(is(values, "list"))
  ##    innernms <- value_names(values)

  if (is.null(labels)) {
    labels <- names(values)
  }
  if (is.null(names) && all(nzchar(labels))) {
    names <- labels
  } else if (is.null(labels) && !is.null(names)) {
    labels <- names
  }

  if (!is.null(indent_mods)) {
    indent_mods <- as.integer(indent_mods)
  }
  check_ok_label(labels, multi_ok = TRUE)
  structure(values,
    class = "RowsVerticalSection", row_names = names,
    row_labels = labels, indent_mods = indent_mods,
    row_formats = formats,
    row_na_strs = format_na_strs,
    row_footnotes = lapply(
      footnotes,
      ## cause each row needs to accept
      ## a *list* of row footnotes
      function(fns) lapply(fns, RefFootnote)
    )
  )
}

#' @method print RowsVerticalSection
#'
#' @export
print.RowsVerticalSection <- function(x, ...) {
  cat("RowsVerticalSection (in_rows) object print method:\n-------------------",
    "---------\n",
    sep = ""
  )
  print(data.frame(
    row_name = attr(x, "row_names", exact = TRUE),
    formatted_cell = vapply(x, format_rcell, character(1)),
    indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)),
    row_label = attr(x, "row_labels", exact = TRUE),
    stringsAsFactors = FALSE,
    row.names = NULL
  ), row.names = TRUE)
  invisible(x)
}

#### Empty default objects to avoid repeated calls
## EmptyColInfo <- InstantiatedColumnInfo()
## EmptyElTable <- ElementaryTable()
## EmptyRootSplit <- RootSplit()
## EmptyAllSplit <- AllSplit()

do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL,
  ## cols = NULL, value) {
  ## don't want this in the recursive function
  ## so thats why we have the do_ variant
  if (is.character(path) && length(path) > 1) {
    path <- as.list(path)
  }
  if (length(path) > 0 && path[[1]] == obj_name(tab)) {
    path <- path[-1]
  }
  recursive_replace(tab, path, value) ## incontent, rows, cols,value)
}

## different cases we want to support:
## 1. Replace entire children for a particular node/position in the tree
## 2. Replace entire rows at a particular (ElementaryTable) position within the
##   tree
## 3. Replace specific cell values within a set of row x column positions within
##   an ElementaryTable at a particular position within the tree
## 3. replace entire content table at a node position
## 4. replace entire rows within the content table at a particular node position
##   in the tree
## 5. replace data cell values for specific row/col positions within the content
##   table at a particular position within the tree

## XXX This is wrong, what happens if a split (or more accurately, value)
## happens more than once in the overall tree???
recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) {
  if (length(path) == 0) { ## done recursing
    ## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position
    ##     if(incontent) {
    ##         newkid = tab
    ##         content_table(newkid) = value
    ##     } else
    newkid <- value
    ## newkid has either thee content table
    ## replaced on the old kid or is the new
    ## kid
    #  } ## else { ## rows or cols (or both)  non-null
    ##     if(incontent) {
    ##         ctab = content_table(tab)
    ##         ctab[rows, cols] = value
    ##         content_table(tab) = ctab
    ##         newkid = tab

    ##     } else {
    ##         allkids = tree_children(tab)
    ##         stopifnot(are(allkids, "TableRow"))
    ##         newkid = tab
    ##         newkid[rows, cols] = value
    ##     }
    ## }
    return(newkid)
  } else if (path[[1]] == "@content") {
    ctb <- content_table(tab)
    ctb <- recursive_replace(ctb,
      path = path[-1],
      ## rows = rows,
      ## cols = cols,
      value = value
    )
    content_table(tab) <- ctb
    tab
  } else { ## length(path) > 1, more recursing to do
    kidel <- path[[1]]
    ## broken up for debugabiliity, could be a single complex
    ## expression
    ## for now only the last step supports selecting
    ## multiple kids
    stopifnot(
      length(kidel) == 1,
      is.character(kidel) || is.factor(kidel)
    )
    knms <- names(tree_children(tab))
    if (!(kidel %in% knms)) {
      stop(sprintf("position element %s not in names of next level children", kidel))
    } else if (sum(kidel == knms) > 1) {
      stop(sprintf("position element %s appears more than once, not currently supported", kidel))
    }
    if (is.factor(kidel)) kidel <- levels(kidel)[kidel]
    newkid <- recursive_replace(
      tree_children(tab)[[kidel]],
      path[-1],
      ## incontent = incontent,
      ## rows = rows,
      ## cols = cols,
      value
    )
    tree_children(tab)[[kidel]] <- newkid
    tab
  }
}

coltree_split <- function(ctree) ctree@split

col_fnotes_at_path <- function(ctree, path, fnotes) {
  if (length(path) == 0) {
    col_footnotes(ctree) <- fnotes
    return(ctree)
  }

  if (identical(path[1], obj_name(coltree_split(ctree)))) {
    path <- path[-1]
  } else {
    stop(paste("Path appears invalid at step:", path[1]))
  }

  kids <- tree_children(ctree)
  kidel <- path[[1]]
  knms <- names(kids)
  stopifnot(kidel %in% knms)
  newkid <- col_fnotes_at_path(kids[[kidel]],
    path[-1],
    fnotes = fnotes
  )
  kids[[kidel]] <- newkid
  tree_children(ctree) <- kids
  ctree
}

#' Insert row at path
#'
#' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and
#' non-label) row, specified by its path.
#'
#' @inheritParams gen_args
#' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after
#'   (`TRUE`) the row specified by `path`.
#'
#' @seealso [DataRow()], [rrow()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' tbl2 <- insert_row_at_path(
#'   tbl, c("COUNTRY", "CHN", "AGE", "Mean"),
#'   rrow("new row", 555)
#' )
#' tbl2
#'
#' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"),
#'   rrow("new row redux", 888),
#'   after = TRUE
#' )
#' tbl3
#'
#' @export
setGeneric("insert_row_at_path",
  signature = c("tt", "value"),
  function(tt, path, value, after = FALSE) {
    standardGeneric("insert_row_at_path")
  }
)

#' @rdname insert_row_at_path
setMethod(
  "insert_row_at_path", c("VTableTree", "DataRow"),
  function(tt, path, value, after = FALSE) {
    if (no_colinfo(value)) {
      col_info(value) <- col_info(tt)
    } else {
      chk_compat_cinfos(tt, value)
    }
    ## retained for debugging
    origpath <- path # nolint
    idx_row <- tt_at_path(tt, path)
    if (!is(idx_row, "DataRow")) {
      stop(
        "path must resolve fully to a non-content data row. Insertion of ",
        "rows elsewhere in the tree is not currently supported."
      )
    }

    posnm <- tail(path, 1)

    path <- head(path, -1)

    subtt <- tt_at_path(tt, path)
    kids <- tree_children(subtt)
    ind <- which(names(kids) == posnm)
    if (length(ind) != 1L) {
      ## nocov start
      stop(
        "table children do not appear to be named correctly at this ",
        "path. This should not happen, please contact the maintainer of ",
        "rtables."
      )
      ## nocov end
    }
    if (after) {
      ind <- ind + 1
    }

    sq <- seq_along(kids)
    tree_children(subtt) <- c(
      kids[sq < ind],
      setNames(list(value), obj_name(value)),
      kids[sq >= ind]
    )
    tt_at_path(tt, path) <- subtt
    tt
  }
)
#' @rdname insert_row_at_path
setMethod(
  "insert_row_at_path", c("VTableTree", "ANY"),
  function(tt, path, value) {
    stop(
      "Currently only insertion of DataRow objects is supported. Got ",
      "object of class ", class(value), ". Please use rrow() or DataRow() ",
      "to construct your row before insertion."
    )
  }
)

#' Label at path
#'
#' Accesses or sets the label at a path.
#'
#' @inheritParams gen_args
#'
#' @details
#' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a
#' subtable, the text for the row-label associated with that path is retrieved or set. In the subtable case, if the
#' label text is set to a non-`NA` value, the `labelrow` will be set to visible, even if it was not before. Similarly,
#' if the label row text for a subtable is set to `NA`, the label row will bet set to non-visible, so the row will not
#' appear at all when the table is printed.
#'
#' @note When changing the row labels for content rows, it is important to path all the way to the *row*. Paths
#' ending in `"@content"` will not exhibit the behavior you want, and are thus an error. See [row_paths()] for help
#' determining the full paths to content rows.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' label_at_path(tbl, c("COUNTRY", "CHN"))
#'
#' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States"
#' tbl
#'
#' @export
label_at_path <- function(tt, path) {
  obj_label(tt_at_path(tt, path))
}

#' @export
#' @rdname label_at_path
`label_at_path<-` <- function(tt, path, value) {
  if (!is(tt, "VTableTree")) {
    stop("tt must be a TableTree or ElementaryTable object")
  }
  if (is.null(value) || is.na(value)) {
    value <- NA_character_
  }
  subt <- tt_at_path(tt, path)
  obj_label(subt) <- value
  tt_at_path(tt, path) <- subt
  tt
}

#' Access or set table elements at specified path
#'
#' @inheritParams gen_args
#' @param ... unused.
#'
#' @export
#' @rdname ttap
setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path"))

#' @inheritParams tt_at_path
#'
#' @export
#' @rdname int_methods
setMethod(
  "tt_at_path", "VTableTree",
  function(tt, path, ...) {
    stopifnot(
      is(path, "character"),
      length(path) > 0,
      !anyNA(path)
    )

    if (path[1] == "root" && obj_name(tt) != "root") {
      path <- path[-1]
    }
    ## handle pathing that hits the root split by name
    if (obj_name(tt) == path[1]) {
      path <- path[-1]
    }
    cur <- tt
    curpath <- path
    while (length(curpath > 0)) {
      kids <- tree_children(cur)
      curname <- curpath[1]
      if (curname == "@content") {
        cur <- content_table(cur)
      } else if (curname %in% names(kids)) {
        cur <- kids[[curname]]
      } else {
        stop("Path appears invalid for this tree at step ", curname)
      }
      curpath <- curpath[-1]
    }
    cur
  }
)

#' @note Setting `NULL` at a defined path removes the corresponding sub-table.
#'
#' @examples
#' # Accessing sub table.
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   split_rows_by("BMRKR2") %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, ex_adsl) %>% prune_table()
#' sub_tbl <- tt_at_path(tbl, path = c("SEX", "F", "BMRKR2"))
#'
#' # Removing sub table.
#' tbl2 <- tbl
#' tt_at_path(tbl2, path = c("SEX", "F")) <- NULL
#' tbl2
#'
#' # Setting sub table.
#' lyt3 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   analyze("BMRKR2")
#'
#' tbl3 <- build_table(lyt3, ex_adsl) %>% prune_table()
#'
#' tt_at_path(tbl3, path = c("SEX", "F", "BMRKR2")) <- sub_tbl
#' tbl3
#'
#' @export
#' @rdname ttap
setGeneric(
  "tt_at_path<-",
  function(tt, path, ..., value) standardGeneric("tt_at_path<-")
)

#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
  "tt_at_path<-", c(tt = "VTableTree", value = "VTableTree"),
  function(tt, path, ..., value) {
    do_recursive_replace(tt, path = path, value = value)
  }
)

## this one removes the child at path from the parents list of children,
## because that is how lists behave.
#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
  "tt_at_path<-", c(tt = "VTableTree", value = "NULL"),
  function(tt, path, ..., value) {
    do_recursive_replace(tt, path = path, value = value)
  }
)

#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
  "tt_at_path<-", c(tt = "VTableTree", value = "TableRow"),
  function(tt, path, ..., value) {
    stopifnot(is(tt_at_path(tt = tt, path = path), "TableRow"))
    do_recursive_replace(tt, path = path, value = value)

    ## ##i <- .path_to_pos(path = path, seq_len(nrow(tt)), tt, NROW)
    ## i <- .path_to_pos(path = path, tt = tt)

    ## replace_rows(tt, i = i, value = list(value))
  }
)

#' Retrieve and assign elements of a `TableTree`
#'
#' @param x (`TableTree`)\cr a `TableTree` object.
#' @param i (`numeric(1)`)\cr index.
#' @param j (`numeric(1)`)\cr index.
#' @param drop (`flag`)\cr whether the value in the cell should be returned if one cell is selected by the
#'   combination of `i` and `j`. It is not possible to return a vector of values. To do so please consider using
#'   [cell_values()]. Defaults to `FALSE`.
#' @param ... additional arguments. Includes:
#'   \describe{
#'     \item{`keep_topleft`}{(`flag`) (`[` only) whether the top-left material for the table should be retained after
#'       subsetting. Defaults to `TRUE` if all rows are included (i.e. subsetting was by column), and drops it
#'       otherwise.}
#'     \item{`keep_titles`}{(`flag`) whether title information should be retained. Defaults to `FALSE`.}
#'     \item{`keep_footers`}{(`flag`) whether non-referential footer information should be retained. Defaults to
#'       `keep_titles`.}
#'     \item{`reindex_refs`}{(`flag`) whether referential footnotes should be re-indexed as if the resulting subset is
#'       the entire table. Defaults to `TRUE`.}
#'   }
#' @param value (`list`, `TableRow`, or `TableTree`)\cr replacement value.
#'
#' @details
#' By default, subsetting drops the information about title, subtitle, main footer, provenance footer, and `topleft`.
#' If only a column is selected and all rows are kept, the `topleft` information remains as default. Any referential
#' footnote is kept whenever the subset table contains the referenced element.
#'
#' @return A `TableTree` (or `ElementaryTable`) object, unless a single cell was selected with `drop = TRUE`, in which
#'   case the (possibly multi-valued) fully stripped raw value of the selected cell.
#'
#' @note
#' Subsetting always preserve the original order, even if provided indexes do not preserve it. If sorting is needed,
#' please consider using `sort_at_path()`. Also note that `character` indices are treated as paths, not vectors of
#' names in both `[` and `[<-`.
#'
#' @seealso
#' * [sort_at_path()] to understand sorting.
#' * [summarize_row_groups()] to understand path structure.
#'
#' @examples
#' lyt <- basic_table(
#'   title = "Title",
#'   subtitles = c("Sub", "titles"),
#'   prov_footer = "prov footer",
#'   main_footer = "main footer"
#' ) %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   analyze(c("AGE"))
#'
#' tbl <- build_table(lyt, DM)
#' top_left(tbl) <- "Info"
#' tbl
#'
#' # As default header, footer, and topleft information is lost
#' tbl[1, ]
#' tbl[1:2, 2]
#'
#' # Also boolean filters can work
#' tbl[, c(FALSE, TRUE, FALSE)]
#'
#' # If drop = TRUE, the content values are directly retrieved
#' tbl[2, 1]
#' tbl[2, 1, drop = TRUE]
#'
#' # Drop works also if vectors are selected, but not matrices
#' tbl[, 1, drop = TRUE]
#' tbl[2, , drop = TRUE]
#' tbl[1, 1, drop = TRUE] # NULL because it is a label row
#' tbl[2, 1:2, drop = TRUE] # vectors can be returned only with cell_values()
#' tbl[1:2, 1:2, drop = TRUE] # no dropping because it is a matrix
#'
#' # If all rows are selected, topleft is kept by default
#' tbl[, 2]
#' tbl[, 1]
#'
#' # It is possible to deselect values
#' tbl[-2, ]
#' tbl[, -1]
#'
#' # Values can be reassigned
#' tbl[2, 1] <- rcell(999)
#' tbl[2, ] <- list(rrow("FFF", 888, 666, 777))
#' tbl[6, ] <- list(-111, -222, -333)
#' tbl
#'
#' # We can keep some information from the original table if we need
#' tbl[1, 2, keep_titles = TRUE]
#' tbl[1, 2, keep_footers = TRUE, keep_titles = FALSE]
#' tbl[1, 2, keep_footers = FALSE, keep_titles = TRUE]
#' tbl[1, 2, keep_footers = TRUE]
#' tbl[1, 2, keep_topleft = TRUE]
#'
#' # Keeps the referential footnotes when subset contains them
#' fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "Mean")) <- "important"
#' tbl[4, 1]
#' tbl[2, 1] # None present
#'
#' # We can reindex referential footnotes, so that the new table does not depend
#' #  on the original one
#' fnotes_at_path(tbl, rowpath = c("SEX", "U", "AGE", "Mean")) <- "important"
#' tbl[, 1] # both present
#' tbl[5:6, 1] # {1} because it has been indexed again
#' tbl[5:6, 1, reindex_refs = FALSE] # {2} -> not reindexed
#'
#' # Note that order can not be changed with subsetting
#' tbl[c(4, 3, 1), c(3, 1)] # It preserves order and wanted selection
#'
#' @name brackets
NULL

#' @exportMethod [<-
#' @rdname brackets
setMethod(
  "[<-", c("VTableTree", value = "list"),
  function(x, i, j, ..., value) {
    nr <- nrow(x)
    if (missing(i)) {
      i <- seq_len(NROW(x))
    } else if (is(i, "character")) {
      i <- .path_to_pos(i, x)
    } else {
      i <- .j_to_posj(i, nr)
    }

    if (missing(j)) {
      j <- seq_along(col_exprs(col_info(x)))
    } else if (is(j, "character")) {
      j <- .path_to_pos(j, x, cols = TRUE)
    } else {
      j <- .j_to_posj(j, ncol(x))
    }

    if (length(i) > 1 && length(j) < ncol(x)) {
      stop("cannot modify multiple rows in not all columns.")
    }

    if (are(value, "TableRow")) {
      value <- rep(value, length.out = length(i))
    } else {
      value <- rep(value, length.out = length(i) * length(j))
    }

    counter <- 0
    ## this has access to value, i, and j by scoping
    replace_rowsbynum <- function(x, i, valifnone = NULL) {
      maxi <- max(i)
      if (counter >= maxi) {
        return(valifnone)
      }

      if (labelrow_visible(x)) {
        counter <<- counter + 1
        if (counter %in% i) {
          nxtval <- value[[1]]
          if (is(nxtval, "LabelRow")) {
            tt_labelrow(x) <- nxtval
          } else {
            stop(
              "can't replace label with value of class",
              class(nxtval)
            )
          }
          ## we're done with this one move to
          ## the next
          value <<- value[-1]
        }
      }
      if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
        ctab <- content_table(x)

        content_table(x) <- replace_rowsbynum(ctab, i)
      }
      if (counter >= maxi) { # already done
        return(x)
      }
      kids <- tree_children(x)

      if (length(kids) > 0) {
        for (pos in seq_along(kids)) {
          curkid <- kids[[pos]]
          if (is(curkid, "TableRow")) {
            counter <<- counter + 1
            if (counter %in% i) {
              nxtval <- value[[1]]
              if (is(nxtval, class(curkid))) {
                if (no_colinfo(nxtval) && length(row_values(nxtval)) == ncol(x)) {
                  col_info(nxtval) <- col_info(x)
                }
                stopifnot(identical(col_info(x), col_info(nxtval)))
                curkid <- nxtval
                value <- value[-1]
              } else {
                rvs <- row_values(curkid)
                rvs[j] <- value[seq_along(j)]
                row_values(curkid) <- rvs
                value <- value[-(seq_along(j))]
              }
              kids[[pos]] <- curkid
            }
          } else {
            kids[[pos]] <- replace_rowsbynum(curkid, i)
          }
          if (counter >= maxi) {
            break
          }
        }
      }
      tree_children(x) <- kids
      x
    }
    replace_rowsbynum(x, i, ...)
  }
)

#' @inheritParams brackets
#'
#' @exportMethod [<-
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[<-", c("VTableTree", value = "CellValue"),
  function(x, i, j, ..., value) {
    x[i = i, j = j, ...] <- list(value)
    x
  }
)

## this is going to be hard :( :( :(

### selecting/removing columns

## we have two options here: path like we do with rows and positional
## in leaf space.

setGeneric(
  "subset_cols",
  function(tt,
           j,
           newcinfo = NULL,
           keep_topleft = TRUE,
           keep_titles = TRUE,
           keep_footers = keep_titles,
           ...) {
    standardGeneric("subset_cols")
  }
)

setMethod(
  "subset_cols", c("TableTree", "numeric"),
  function(tt, j, newcinfo = NULL,
           keep_topleft, keep_titles, keep_footers, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j,
        keep_topleft = keep_topleft, ...
      )
    }
    ## topleft taken care of in creation of newcinfo
    kids <- tree_children(tt)
    newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)
    cont <- content_table(tt)
    newcont <- subset_cols(cont, j, newcinfo = newcinfo, ...)
    tt2 <- tt
    col_info(tt2) <- newcinfo
    content_table(tt2) <- newcont
    tree_children(tt2) <- newkids
    tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)

    tt2 <- .h_copy_titles_footers_topleft(
      tt2, tt,
      keep_titles,
      keep_footers,
      keep_topleft
    )
    tt2
  }
)

setMethod(
  "subset_cols", c("ElementaryTable", "numeric"),
  function(tt, j, newcinfo = NULL,
           keep_topleft, keep_titles, keep_footers, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j,
        keep_topleft = keep_topleft,
        keep_titles = keep_titles,
        keep_footers = keep_footers, ...
      )
    }
    ## topleft handled in creation of newcinfo
    kids <- tree_children(tt)
    newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)
    tt2 <- tt
    col_info(tt2) <- newcinfo
    tree_children(tt2) <- newkids
    tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)
    tt2 <- .h_copy_titles_footers_topleft(
      tt2, tt,
      keep_titles,
      keep_footers,
      keep_topleft
    )
    tt2
  }
)

## small utility to transform any negative
## indices into positive ones, given j
## and total length

.j_to_posj <- function(j, n) {
  ## This will work for logicals, numerics, integers
  j <- seq_len(n)[j]
  j
}

path_collapse_sep <- "`"
escape_name_padding <- function(x) {
  ret <- gsub("._[[", "\\._\\[\\[", x, fixed = TRUE)
  ret <- gsub("]]_.", "\\]\\]_\\.", ret, fixed = TRUE)
  ret
}
path_to_regex <- function(path) {
  paste(vapply(path, function(x) {
    if (identical(x, "*")) {
      paste0("[^", path_collapse_sep, "]+")
    } else {
      escape_name_padding(x)
    }
  }, ""), collapse = path_collapse_sep)
}

.path_to_pos <- function(path, tt, distinct_ok = TRUE, cols = FALSE) {
  path <- path[!grepl("^(|root)$", path)]
  if (cols) {
    rowdf <- make_col_df(tt)
  } else {
    rowdf <- make_row_df(tt)
  }
  if (length(path) == 0 || identical(path, "*") || identical(path, "root")) {
    return(seq(1, nrow(rowdf)))
  }

  paths <- rowdf$path
  pathregex <- path_to_regex(path)
  pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep)
  allmatchs <- grep(pathregex, pathstrs)
  if (length(allmatchs) == 0) {
    stop(
      if (cols) "column path [" else "row path [",
      paste(path, collapse = "->"),
      "] does not appear valid for this table"
    )
  }

  idxdiffs <- diff(allmatchs)
  if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) {
    firstnon <- min(which(idxdiffs > 1))
    ## its firstnon here because we would want firstnon-1 but
    ## the diffs are actually shifted 1 so they cancel out
    allmatchs <- allmatchs[seq(1, firstnon)]
  }
  allmatchs
}

## fix column spans that would be invalid
## after some columns are no longer there
.fix_rowcspans <- function(rw, j) {
  cspans <- row_cspans(rw)
  nc <- sum(cspans)
  j <- .j_to_posj(j, nc)
  ## this is overly complicated
  ## we need the starting indices
  ## but the first span might not be 1, so
  ## we pad with 1 and then take off the last
  start <- cumsum(c(1, head(cspans, -1)))
  ends <- c(tail(start, -1) - 1, nc)
  res <- mapply(function(st, en) {
    sum(j >= st & j <= en)
  }, st = start, en = ends)
  res <- res[res > 0]
  stopifnot(sum(res) == length(j))
  res
}

select_cells_j <- function(cells, j) {
  if (length(j) != length(unique(j))) {
    stop("duplicate column selections is not currently supported")
  }
  spans <- vapply(
    cells, function(x) cell_cspan(x),
    integer(1)
  )
  inds <- rep(seq_along(cells), times = spans)
  selinds <- inds[j]
  retcells <- cells[selinds[!duplicated(selinds)]]
  newspans <- vapply(
    split(selinds, selinds),
    length,
    integer(1)
  )

  mapply(function(cl, sp) {
    cell_cspan(cl) <- sp
    cl
  }, cl = retcells, sp = newspans, SIMPLIFY = FALSE)
}

setMethod(
  "subset_cols", c("ANY", "character"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    j <- .path_to_pos(path = j, tt = tt, cols = TRUE)
    subset_cols(tt, j, newcinfo = newcinfo, keep_topleft = keep_topleft, ...)
  }
)

setMethod(
  "subset_cols", c("TableRow", "numeric"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)
    }
    tt2 <- tt
    row_cells(tt2) <- select_cells_j(row_cells(tt2), j)

    if (length(row_cspans(tt2)) > 0) {
      row_cspans(tt2) <- .fix_rowcspans(tt2, j)
    }
    col_info(tt2) <- newcinfo
    tt2
  }
)

setMethod(
  "subset_cols", c("LabelRow", "numeric"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    j <- .j_to_posj(j, ncol(tt))
    if (is.null(newcinfo)) {
      cinfo <- col_info(tt)
      newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)
    }
    col_info(tt) <- newcinfo
    tt
  }
)

setMethod(
  "subset_cols", c("InstantiatedColumnInfo", "numeric"),
  function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
    if (!is.null(newcinfo)) {
      return(newcinfo)
    }
    j <- .j_to_posj(j, length(col_exprs(tt)))
    newctree <- subset_cols(coltree(tt), j, NULL)
    newcextra <- col_extra_args(tt)[j]
    newcsubs <- col_exprs(tt)[j]
    newcounts <- col_counts(tt)[j]
    tl <- if (keep_topleft) top_left(tt) else character()
    InstantiatedColumnInfo(
      treelyt = newctree,
      csubs = newcsubs,
      extras = newcextra,
      cnts = newcounts,
      dispcounts = disp_ccounts(tt),
      countformat = colcount_format(tt),
      topleft = tl
    )
  }
)

setMethod(
  "subset_cols", c("LayoutColTree", "numeric"),
  function(tt, j, newcinfo = NULL, ...) {
    lst <- collect_leaves(tt)
    j <- .j_to_posj(j, length(lst))

    ## j has only non-negative values from
    ## this point on
    counter <- 0
    prune_children <- function(x, j) {
      kids <- tree_children(x)
      newkids <- kids
      for (i in seq_along(newkids)) {
        if (is(newkids[[i]], "LayoutColLeaf")) {
          counter <<- counter + 1
          if (!(counter %in% j)) {
            newkids[[i]] <- list()
          } ## NULL removes the position entirely
        } else {
          newkids[[i]] <- prune_children(newkids[[i]], j)
        }
      }

      newkids <- newkids[sapply(newkids, function(thing) length(thing) > 0)]
      if (length(newkids) > 0) {
        tree_children(x) <- newkids
        x
      } else {
        list()
      }
    }
    prune_children(tt, j)
  }
)

## label rows ARE included in the count
subset_by_rownum <- function(tt,
                             i,
                             keep_topleft = FALSE,
                             keep_titles = TRUE,
                             keep_footers = keep_titles,
                             ...) {
  stopifnot(is(tt, "VTableNodeInfo"))
  counter <- 0
  nr <- nrow(tt)
  i <- .j_to_posj(i, nr)
  if (length(i) == 0) {
    ret <- TableTree(cinfo = col_info(tt))
    if (isTRUE(keep_topleft)) {
      top_left(ret) <- top_left(tt)
    }
    return(ret)
  }

  prune_rowsbynum <- function(x, i, valifnone = NULL) {
    maxi <- max(i)
    if (counter > maxi) {
      return(valifnone)
    }

    if (labelrow_visible(x)) {
      counter <<- counter + 1
      if (!(counter %in% i)) {
        ## XXX this should do whatever
        ## is required to 'remove' the Label Row
        ## (currently implicit based on
        ## the value of the label but
        ## that shold really probably change)
        labelrow_visible(x) <- FALSE
      }
    }
    if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
      ctab <- content_table(x)

      content_table(x) <- prune_rowsbynum(ctab, i,
        valifnone = ElementaryTable(
          cinfo = col_info(ctab),
          iscontent = TRUE
        )
      )
    }
    kids <- tree_children(x)
    if (counter > maxi) { # already done
      kids <- list()
    } else if (length(kids) > 0) {
      for (pos in seq_along(kids)) {
        if (is(kids[[pos]], "TableRow")) {
          counter <<- counter + 1
          if (!(counter %in% i)) {
            kids[[pos]] <- list()
          }
        } else {
          kids[[pos]] <- prune_rowsbynum(kids[[pos]], i, list())
        }
      }
      kids <- kids[sapply(kids, function(x) NROW(x) > 0)]
    }
    if (length(kids) == 0 && NROW(content_table(x)) == 0 && !labelrow_visible(x)) {
      return(valifnone)
    } else {
      tree_children(x) <- kids
      x
    }
    ## ## if(length(kids) == 0) {
    ## ##     if(!is(x, "TableTree"))
    ## ##         return(valifnone)
    ## ## }
    ## if(is(x, "VTableTree") && nrow(x) > 0) {
    ##     x
    ## } else {
    ##     valifnone
    ## }
  }
  ret <- prune_rowsbynum(tt, i)

  ret <- .h_copy_titles_footers_topleft(
    ret, tt,
    keep_titles,
    keep_footers,
    keep_topleft
  )

  ret
}

#' @exportMethod [
#' @rdname brackets
setMethod(
  "[", c("VTableTree", "logical", "logical"),
  function(x, i, j, ..., drop = FALSE) {
    i <- .j_to_posj(i, nrow(x))
    j <- .j_to_posj(j, ncol(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "logical", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
    i <- .j_to_posj(i, nrow(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "logical", "missing"),
  function(x, i, j, ..., drop = FALSE) {
    j <- seq_len(ncol(x))
    i <- .j_to_posj(i, nrow(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "ANY", "logical"),
  function(x, i, j, ..., drop = FALSE) {
    j <- .j_to_posj(j, ncol(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "ANY", "missing"),
  function(x, i, j, ..., drop = FALSE) {
    j <- seq_len(ncol(x))
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "missing", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
    i <- seq_len(nrow(x))
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "ANY", "character"),
  function(x, i, j, ..., drop = FALSE) {
    ## j <- .colpath_to_j(j, coltree(x))
    j <- .path_to_pos(path = j, tt = x, cols = TRUE)
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "character", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
    ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)
    i <- .path_to_pos(i, x)
    x[i = i, j = j, ..., drop = drop]
  }
)

## to avoid dispatch ambiguity. Not necessary, possibly not a good idea at all
#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "character", "character"),
  function(x, i, j, ..., drop = FALSE) {
    ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)
    i <- .path_to_pos(i, x)
    ## j <- .colpath_to_j(j, coltree(x))
    j <- .path_to_pos(path = j, tt = x, cols = TRUE)
    x[i = i, j = j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "missing", "numeric"),
  function(x, i, j, ..., drop = FALSE) {
    i <- seq_len(nrow(x))
    x[i, j, ..., drop = drop]
  }
)

#' @exportMethod [
#' @rdname int_methods
#' @keywords internal
setMethod(
  "[", c("VTableTree", "numeric", "numeric"),
  function(x, i, j, ..., drop = FALSE) {
    ## have to do it this way because we can't add an argument since we don't
    ## own the generic declaration
    keep_topleft <- list(...)[["keep_topleft"]] %||% NA
    keep_titles <- list(...)[["keep_titles"]] %||% FALSE
    keep_footers <- list(...)[["keep_footers"]] %||% keep_titles
    reindex_refs <- list(...)[["reindex_refs"]] %||% TRUE

    nr <- nrow(x)
    nc <- ncol(x)
    i <- .j_to_posj(i, nr)
    j <- .j_to_posj(j, nc)

    ##  if(!missing(i) && length(i) < nr) {
    if (length(i) < nr) { ## already populated by .j_to_posj
      keep_topleft <- isTRUE(keep_topleft)
      x <- subset_by_rownum(x, i,
        keep_topleft = keep_topleft,
        keep_titles = keep_titles,
        keep_footers = keep_footers
      )
    } else if (is.na(keep_topleft)) {
      keep_topleft <- TRUE
    }

    ##  if(!missing(j) && length(j) < nc)
    if (length(j) < nc) {
      x <- subset_cols(x, j,
        keep_topleft = keep_topleft,
        keep_titles = keep_titles,
        keep_footers = keep_footers
      )
    }

    # Dropping everything
    if (drop) {
      if (length(j) == 1L && length(i) == 1L) {
        rw <- collect_leaves(x, TRUE, TRUE)[[1]]
        if (is(rw, "LabelRow")) {
          warning(
            "The value selected with drop = TRUE belongs ",
            "to a label row. NULL will be returned"
          )
          x <- NULL
        } else {
          x <- row_values(rw)[[1]]
        }
      } else {
        warning(
          "Trying to drop more than one subsetted value. ",
          "We support this only with accessor function `cell_values()`. ",
          "No drop will be done at this time."
        )
        drop <- FALSE
      }
    }
    if (!drop) {
      if (!keep_topleft) {
        top_left(x) <- character()
      }
      if (reindex_refs) {
        x <- update_ref_indexing(x)
      }
    }
    x
  }
)

#' @importFrom utils compareVersion

setGeneric("tail", tail)

setMethod(
  "tail", "VTableTree",
  function(x, n = 6L, ...) {
    if (compareVersion("4.0.0", as.character(getRversion())) <= 0) {
      tail.matrix(x, n, keepnums = FALSE)
    } else {
      tail.matrix(x, n, addrownums = FALSE)
    }
  }
)

setGeneric("head", head)

setMethod(
  "head", "VTableTree",
  function(x, n = 6L, ...) {
    head.matrix(x, n)
  }
)

#' Retrieve cell values by row and column path
#'
#' @inheritParams gen_args
#' @param rowpath (`character`)\cr path in row-split space to the desired row(s). Can include `"@content"`.
#' @param colpath (`character`)\cr path in column-split space to the desired column(s). Can include `"*"`.
#' @param omit_labrows (`flag`)\cr whether label rows underneath `rowpath` should be omitted (`TRUE`, the default),
#'   or return empty lists of cell "values" (`FALSE`).
#'
#' @return
#' * `cell_values` returns a `list` (regardless of the type of value the cells hold). If `rowpath` defines a path to
#'   a single row, `cell_values` returns the list of cell values for that row, otherwise a list of such lists, one for
#'   each row captured underneath `rowpath`. This occurs after subsetting to `colpath` has occurred.
#' * `value_at` returns the "unwrapped" value of a single cell, or an error, if the combination of `rowpath` and
#'   `colpath` do not define the location of a single cell in `tt`.
#'
#' @note `cell_values` will return a single cell's value wrapped in a list. Use `value_at` to receive the "bare" cell
#'   value.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX") %>%
#'   split_rows_by("RACE") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   analyze("AGE")
#'
#' @examplesIf require(dplyr)
#' library(dplyr) ## for mutate
#' tbl <- build_table(lyt, DM %>%
#'   mutate(SEX = droplevels(SEX), RACE = droplevels(RACE)))
#'
#' row_paths_summary(tbl)
#' col_paths_summary(tbl)
#'
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B"),
#'   c("ARM", "A: Drug X", "SEX", "F")
#' )
#'
#' # it's also possible to access multiple values by being less specific
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1"),
#'   c("ARM", "A: Drug X", "SEX", "F")
#' )
#' cell_values(tbl, c("RACE", "ASIAN"), c("ARM", "A: Drug X", "SEX", "M"))
#'
#' ## any arm, male columns from the ASIAN content (i.e. summary) row
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "@content"),
#'   c("ARM", "B: Placebo", "SEX", "M")
#' )
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "@content"),
#'   c("ARM", "*", "SEX", "M")
#' )
#'
#' ## all columns
#' cell_values(tbl, c("RACE", "ASIAN", "STRATA1", "B"))
#'
#' ## all columns for the Combination arm
#' cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B"),
#'   c("ARM", "C: Combination")
#' )
#'
#' cvlist <- cell_values(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
#'   c("ARM", "B: Placebo", "SEX", "M")
#' )
#' cvnolist <- value_at(
#'   tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
#'   c("ARM", "B: Placebo", "SEX", "M")
#' )
#' stopifnot(identical(cvlist[[1]], cvnolist))
#'
#' @rdname cell_values
#' @export
setGeneric("cell_values", function(tt, rowpath = NULL, colpath = NULL, omit_labrows = TRUE) {
  standardGeneric("cell_values")
})

#' @rdname int_methods
#' @keywords internal
#' @exportMethod cell_values
setMethod(
  "cell_values", "VTableTree",
  function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = omit_labrows, value_at = FALSE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod cell_values
setMethod(
  "cell_values", "TableRow",
  function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
    if (!is.null(rowpath)) {
      stop("cell_values on TableRow objects must have NULL rowpath")
    }
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = omit_labrows, value_at = FALSE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod cell_values
setMethod(
  "cell_values", "LabelRow",
  function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
    stop("calling cell_values on LabelRow is not meaningful")
  }
)

#' @rdname cell_values
#' @export
setGeneric("value_at", function(tt, rowpath = NULL, colpath = NULL) {
  standardGeneric("value_at")
})

#' @rdname cell_values
#' @exportMethod value_at
setMethod(
  "value_at", "VTableTree",
  function(tt, rowpath, colpath = NULL) {
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = FALSE, value_at = TRUE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod value_at
setMethod(
  "value_at", "TableRow",
  function(tt, rowpath, colpath = NULL) {
    .inner_cell_value(tt,
      rowpath = rowpath, colpath = colpath,
      omit_labrows = FALSE, value_at = TRUE
    )
  }
)

#' @rdname int_methods
#' @keywords internal
#' @exportMethod value_at
setMethod(
  "value_at", "LabelRow",
  function(tt, rowpath, colpath = NULL) {
    stop("calling value_at for LabelRow objects is not meaningful")
  }
)

.inner_cell_value <- function(tt,
                              rowpath,
                              colpath = NULL,
                              omit_labrows = TRUE,
                              value_at = FALSE) {
  if (is.null(rowpath)) {
    subtree <- tt
  } else {
    subtree <- tt_at_path(tt, rowpath)
  }
  if (!is.null(colpath)) {
    subtree <- subset_cols(subtree, colpath)
  }

  rows <- collect_leaves(subtree, TRUE, !omit_labrows)
  if (value_at && (ncol(subtree) != 1 || length(rows) != 1)) {
    stop("Combination of rowpath and colpath does not select individual cell.\n",
      "  To retrieve more than one cell value at a time use cell_values().",
      call. = FALSE
    )
  }
  if (length(rows) == 1) {
    ret <- row_values(rows[[1]])
    if (value_at && ncol(subtree) == 1) {
      ret <- ret[[1]]
    }
    ret
  } else {
    lapply(rows, row_values)
  }
}

## empty_table is created in onLoad because it depends on other things there.

# Helper function to copy or not header, footer, and topleft information
.h_copy_titles_footers_topleft <- function(new,
                                           old,
                                           keep_titles,
                                           keep_footers,
                                           keep_topleft,
                                           reindex_refs = FALSE,
                                           empt_tbl = empty_table) {
  ## Please note that the standard adopted come from an empty table

  # titles
  if (isTRUE(keep_titles)) {
    main_title(new) <- main_title(old)
    subtitles(new) <- subtitles(old)
  } else {
    main_title(new) <- main_title(empt_tbl)
    subtitles(new) <- subtitles(empt_tbl)
  }

  # fnotes
  if (isTRUE(keep_footers)) {
    main_footer(new) <- main_footer(old)
    prov_footer(new) <- prov_footer(old)
  } else {
    main_footer(new) <- main_footer(empt_tbl)
    prov_footer(new) <- prov_footer(empt_tbl)
  }

  # topleft
  if (isTRUE(keep_topleft)) {
    top_left(new) <- top_left(old)
  } else {
    top_left(new) <- top_left(empt_tbl)
  }

  # reindex references
  if (reindex_refs) {
    new <- update_ref_indexing(new)
  }

  new
}

#' Head and tail methods
#'
#' @inheritParams utils::head
#' @param keep_topleft (`flag`)\cr if `TRUE` (the default), top_left material for the table will be carried over to the
#'   subset.
#' @param keep_titles (`flag`)\cr if `TRUE` (the default), all title material for the table will be carried over to the
#'   subset.
#' @param keep_footers (`flag`)\cr if `TRUE`, all footer material for the table will be carried over to the subset. It
#'   defaults to `keep_titles`.
#' @param reindex_refs (`flag`)\cr defaults to `FALSE`. If `TRUE`, referential footnotes will be reindexed for the
#'   subset.
#'
#' @docType methods
#' @export
#' @rdname head_tail
setGeneric("head")

#' @docType methods
#' @export
#' @rdname head_tail
setMethod(
  "head", "VTableTree",
  function(x, n = 6, ..., keep_topleft = TRUE,
           keep_titles = TRUE,
           keep_footers = keep_titles,
           ## FALSE because this is a glance
           ## more often than a subset op
           reindex_refs = FALSE) {
    ## default
    res <- callNextMethod()
    res <- .h_copy_titles_footers_topleft(
      old = x, new = res,
      keep_topleft = keep_topleft,
      keep_titles = keep_titles,
      keep_footers = keep_footers,
      reindex_refs = reindex_refs
    )
    res
  }
)

#' @docType methods
#' @export
#' @rdname head_tail
setGeneric("tail")

#' @docType methods
#' @export
#' @rdname head_tail
setMethod(
  "tail", "VTableTree",
  function(x, n = 6, ..., keep_topleft = TRUE,
           keep_titles = TRUE,
           keep_footers = keep_titles,
           ## FALSE because this is a glance
           ## more often than a subset op
           reindex_refs = FALSE) {
    res <- callNextMethod()
    res <- .h_copy_titles_footers_topleft(
      old = x, new = res,
      keep_topleft = keep_topleft,
      keep_titles = keep_titles,
      keep_footers = keep_footers,
      reindex_refs = reindex_refs
    )
    res
  }
)

#' Change indentation of all `rrows` in an `rtable`
#'
#' Change indentation of all `rrows` in an `rtable`
#'
#' @param x (`VTableTree`)\cr an `rtable` object.
#' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is
#'   less than 0, the indentation is set to 0.
#'
#' @return `x` with its indent modifier incremented by `by`.
#'
#' @examples
#' is_setosa <- iris$Species == "setosa"
#' m_tbl <- rtable(
#'   header = rheader(
#'     rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
#'     rrow(NULL, "mean", "median", "mean", "median")
#'   ),
#'   rrow(
#'     row.name = "All Species",
#'     mean(iris$Sepal.Length), median(iris$Sepal.Length),
#'     mean(iris$Petal.Length), median(iris$Petal.Length),
#'     format = "xx.xx"
#'   ),
#'   rrow(
#'     row.name = "Setosa",
#'     mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]),
#'     mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]),
#'     format = "xx.xx"
#'   )
#' )
#' indent(m_tbl)
#' indent(m_tbl, 2)
#'
#' @export
indent <- function(x, by = 1) {
  if (nrow(x) == 0 || by == 0) {
    return(x)
  }

  indent_mod(x) <- indent_mod(x) + by
  x
}

#' Clear all indent modifiers from a table
#'
#' @inheritParams gen_args
#'
#' @return The same class as `tt`, with all indent modifiers set to zero.
#'
#' @examples
#' lyt1 <- basic_table() %>%
#'   summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
#'   split_rows_by("AEBODSYS", child_labels = "visible") %>%
#'   summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
#'   analyze("AGE", indent_mod = -1L)
#'
#' tbl1 <- build_table(lyt1, ex_adae)
#' tbl1
#' clear_indent_mods(tbl1)
#'
#' @export
#' @rdname clear_imods
setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))

#' @export
#' @rdname clear_imods
setMethod(
  "clear_indent_mods", "VTableTree",
  function(tt) {
    ct <- content_table(tt)
    if (!is.null(ct)) {
      content_table(tt) <- clear_indent_mods(ct)
    }
    tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)
    indent_mod(tt) <- 0L
    tt
  }
)

#' @export
#' @rdname clear_imods
setMethod(
  "clear_indent_mods", "TableRow",
  function(tt) {
    indent_mod(tt) <- 0L
    tt
  }
)

## Rules for pagination
##
## 1. user defined number of lines per page
## 2. all lines have the same height
## 3. header always reprinted on all pages
## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE)
## 5. Never (?) break on a "label"/content row
## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table.
##
## Current behavior: paginate_ttree takes a TableTree object and
## returns a list of rtable (S3) objects for printing.

#' @inheritParams formatters::nlines
#'
#' @rdname formatters_methods
#' @aliases nlines,TableRow-method
#' @exportMethod nlines
setMethod(
  "nlines", "TableRow",
  function(x, colwidths, max_width, fontspec, col_gap = 3) {
    fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) +
      sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))
    fcells <- as.vector(get_formatted_cells(x))
    spans <- row_cspans(x)
    have_cw <- !is.null(colwidths)
    ## handle spanning so that the projected word-wrapping from nlines is correct
    if (any(spans > 1)) {
      new_fcells <- character(length(spans))
      new_colwidths <- numeric(length(spans))
      cur_fcells <- fcells
      cur_colwidths <- colwidths[-1] ## not the row labels they can't span
      for (i in seq_along(spans)) {
        spi <- spans[i]
        new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop
        new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1)
        cur_fcells <- tail(cur_fcells, -1 * spi)
        cur_colwidths <- tail(cur_colwidths, -1 * spi)
      }
      if (have_cw) {
        colwidths <- c(colwidths[1], new_colwidths)
      }
      fcells <- new_fcells
    }

    ## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE),
    ##                      length,
    ##                      1L))
    rowext <- max(
      unlist(
        mapply(
          function(s, w) {
            nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec)
          },
          s = c(obj_label(x), fcells),
          w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
          SIMPLIFY = FALSE
        )
      )
    )

    rowext + fns
  }
)

#' @export
#' @rdname formatters_methods
setMethod(
  "nlines", "LabelRow",
  function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
    if (labelrow_visible(x)) {
      nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) +
        sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))
    } else {
      0L
    }
  }
)

#' @export
#' @rdname formatters_methods
setMethod(
  "nlines", "RefFootnote",
  function(x, colwidths, max_width, fontspec, col_gap = NULL) {
    nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
  }
)

#' @export
#' @rdname formatters_methods
setMethod(
  "nlines", "InstantiatedColumnInfo",
  function(x, colwidths, max_width, fontspec, col_gap = 3) {
    h_rows <- .do_tbl_h_piece2(x)
    tl <- top_left(x) %||% rep("", length(h_rows))
    main_nls <- vapply(
      seq_along(h_rows),
      function(i) {
        max(
          nlines(h_rows[[i]],
            colwidths = colwidths,
            fontspec = fontspec,
            col_gap = col_gap
          ),
          nlines(tl[i],
            colwidths = colwidths[1],
            fontspec = fontspec
          )
        )
      },
      1L
    )

    ## lfs <- collect_leaves(coltree(x))
    ## depths <- sapply(lfs, function(l) length(pos_splits(l)))

    coldf <- make_col_df(x, colwidths = colwidths)
    have_fnotes <- length(unlist(coldf$col_fnotes)) > 0
    ## ret <- max(depths, length(top_left(x))) +
    ##     divider_height(x)
    ret <- sum(main_nls, divider_height(x))
    if (have_fnotes) {
      ret <- sum(
        ret,
        vapply(unlist(coldf$col_fnotes),
          nlines,
          1,
          max_width = max_width,
          fontspec = fontspec
        ),
        2 * divider_height(x)
      )
    }
    ret
  }
)

col_dfrow <- function(col,
                      nm = obj_name(col),
                      lab = obj_label(col),
                      cnum,
                      pth = NULL,
                      sibpos = NA_integer_,
                      nsibs = NA_integer_,
                      leaf_indices = cnum,
                      span = length(leaf_indices),
                      col_fnotes = list(),
                      col_count = facet_colcount(col, NULL),
                      ccount_visible = disp_ccounts(col),
                      ccount_format = colcount_format(col),
                      ccount_na_str,
                      global_cc_format) {
  if (is.null(pth)) {
    pth <- pos_to_path(tree_pos(col))
  }
  data.frame(
    stringsAsFactors = FALSE,
    name = nm,
    label = lab,
    abs_pos = cnum,
    path = I(list(pth)),
    pos_in_siblings = sibpos,
    n_siblings = nsibs,
    leaf_indices = I(list(leaf_indices)),
    total_span = span,
    col_fnotes = I(list(col_fnotes)),
    n_col_fnotes = length(col_fnotes),
    col_count = col_count,
    ccount_visible = ccount_visible,
    ccount_format = ccount_format %||% global_cc_format,
    ccount_na_str = ccount_na_str
  )
}

pos_to_path <- function(pos) {
  spls <- pos_splits(pos)
  vals <- pos_splvals(pos)

  path <- character()
  for (i in seq_along(spls)) {
    nm <- obj_name(spls[[i]])
    val_i <- value_names(vals[[i]])
    path <- c(
      path,
      obj_name(spls[[i]]),
      ## rawvalues(vals[[i]]))
      if (!is.na(val_i)) val_i
    )
  }
  path
}

# make_row_df ---------------------------------------------------------------

#' @inherit formatters::make_row_df
#'
# #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and
# #'   `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination.
# #'
# #' @return a data.frame of row/column-structure information used by the pagination machinery.
# #'
# #' @export
# #' @name make_row_df
# #' @rdname make_row_df
# #' @aliases make_row_df,VTableTree-method
#' @rdname formatters_methods
#' @exportMethod make_row_df
setMethod(
  "make_row_df", "VTableTree",
  function(tt,
           colwidths = NULL,
           visible_only = TRUE,
           rownum = 0,
           indent = 0L,
           path = character(),
           incontent = FALSE,
           repr_ext = 0L,
           repr_inds = integer(),
           sibpos = NA_integer_,
           nsibs = NA_integer_,
           max_width = NULL,
           fontspec = NULL,
           col_gap = 3) {
    indent <- indent + indent_mod(tt)
    ## retained for debugging info
    orig_rownum <- rownum # nolint
    if (incontent) {
      path <- c(path, "@content")
    } else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root
      ## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint
      path <- c(path, obj_name(tt))
    }
    ret <- list()

    ## note this is the **table** not the label row
    if (!visible_only) {
      ret <- c(
        ret,
        list(pagdfrow(
          rnum = NA,
          nm = obj_name(tt),
          lab = "",
          pth = path,
          colwidths = colwidths,
          repext = repr_ext,
          repind = list(repr_inds),
          extent = 0,
          indent = indent,
          rclass = class(tt), sibpos = sibpos,
          nsibs = nsibs,
          nrowrefs = 0L,
          ncellrefs = 0L,
          nreflines = 0L,
          fontspec = fontspec
        ))
      )
    }
    if (labelrow_visible(tt)) {
      lr <- tt_labelrow(tt)
      newdf <- make_row_df(lr,
        colwidths = colwidths,
        visible_only = visible_only,
        rownum = rownum,
        indent = indent,
        path = path,
        incontent = TRUE,
        repr_ext = repr_ext,
        repr_inds = repr_inds,
        max_width = max_width,
        fontspec = fontspec
      )
      rownum <- max(newdf$abs_rownumber, na.rm = TRUE)

      ret <- c(
        ret,
        list(newdf)
      )
      repr_ext <- repr_ext + 1L
      repr_inds <- c(repr_inds, rownum)
      indent <- indent + 1L
    }

    if (NROW(content_table(tt)) > 0) {
      ct_tt <- content_table(tt)
      cind <- indent + indent_mod(ct_tt)
      trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt))
      contdf <- make_row_df(ct_tt,
        colwidths = colwidths,
        visible_only = visible_only,
        rownum = rownum,
        indent = cind,
        path = path,
        incontent = TRUE,
        repr_ext = repr_ext,
        repr_inds = repr_inds,
        max_width = max_width,
        fontspec = fontspec
      )
      crnums <- contdf$abs_rownumber
      crnums <- crnums[!is.na(crnums)]

      newrownum <- max(crnums, na.rm = TRUE)
      if (is.finite(newrownum)) {
        rownum <- newrownum
        repr_ext <- repr_ext + length(crnums)
        repr_inds <- c(repr_inds, crnums)
      }
      ret <- c(ret, list(contdf))
      indent <- cind + 1
    }

    allkids <- tree_children(tt)
    newnsibs <- length(allkids)
    for (i in seq_along(allkids)) {
      kid <- allkids[[i]]
      kiddfs <- make_row_df(kid,
        colwidths = colwidths,
        visible_only = visible_only,
        rownum = force(rownum),
        indent = indent, ## + 1,
        path = path,
        incontent = incontent,
        repr_ext = repr_ext,
        repr_inds = repr_inds,
        nsibs = newnsibs,
        sibpos = i,
        max_width = max_width,
        fontspec = fontspec
      )

      #       print(kiddfs$abs_rownumber)
      rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE)
      ret <- c(ret, list(kiddfs))
    }

    ret <- do.call(rbind, ret)

    # Case where it has Elementary table or VTableTree section_div it is overridden
    if (!is.na(trailing_section_div(tt))) {
      ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt)
    }
    ret
  }
)

# #' @exportMethod make_row_df
#' @inherit formatters::make_row_df
#'
#' @export
#' @rdname formatters_methods
setMethod(
  "make_row_df", "TableRow",
  function(tt, colwidths = NULL, visible_only = TRUE,
           rownum = 0,
           indent = 0L,
           path = "root",
           incontent = FALSE,
           repr_ext = 0L,
           repr_inds = integer(),
           sibpos = NA_integer_,
           nsibs = NA_integer_,
           max_width = NULL,
           fontspec,
           col_gap = 3) {
    indent <- indent + indent_mod(tt)
    rownum <- rownum + 1
    rrefs <- row_footnotes(tt)
    crefs <- cell_footnotes(tt)
    reflines <- sum(
      sapply(
        c(rrefs, crefs),
        nlines,
        colwidths = colwidths,
        max_width = max_width,
        fontspec = fontspec,
        col_gap = col_gap
      )
    ) ## col_gap not strictly necessary as these aren't rows, but why not
    ret <- pagdfrow(
      row = tt,
      rnum = rownum,
      colwidths = colwidths,
      sibpos = sibpos,
      nsibs = nsibs,
      pth = c(path, unname(obj_name(tt))),
      repext = repr_ext,
      repind = repr_inds,
      indent = indent,
      extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),
      ## these two are unlist calls cause they come in lists even with no footnotes
      nrowrefs = length(rrefs),
      ncellrefs = length(unlist(crefs)),
      nreflines = reflines,
      trailing_sep = trailing_section_div(tt),
      fontspec = fontspec
    )
    ret
  }
)

# #' @exportMethod make_row_df
#' @export
#' @rdname formatters_methods
setMethod(
  "make_row_df", "LabelRow",
  function(tt, colwidths = NULL, visible_only = TRUE,
           rownum = 0,
           indent = 0L,
           path = "root",
           incontent = FALSE,
           repr_ext = 0L,
           repr_inds = integer(),
           sibpos = NA_integer_,
           nsibs = NA_integer_,
           max_width = NULL,
           fontspec,
           col_gap = 3) {
    rownum <- rownum + 1
    indent <- indent + indent_mod(tt)
    ret <- pagdfrow(tt,
      extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),
      rnum = rownum,
      colwidths = colwidths,
      sibpos = sibpos,
      nsibs = nsibs,
      pth = path,
      repext = repr_ext,
      repind = repr_inds,
      indent = indent,
      nrowrefs = length(row_footnotes(tt)),
      ncellrefs = 0L,
      nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_,
        colwidths = colwidths,
        max_width = max_width,
        fontspec = fontspec,
        col_gap = col_gap
      )),
      trailing_sep = trailing_section_div(tt),
      fontspec = fontspec
    )
    if (!labelrow_visible(tt)) {
      ret <- ret[0, , drop = FALSE]
    }
    ret
  }
)

setGeneric("inner_col_df", function(ct,
                                    colwidths = NULL,
                                    visible_only = TRUE,
                                    colnum = 0L,
                                    sibpos = NA_integer_,
                                    nsibs = NA_integer_,
                                    ncolref = 0L,
                                    na_str,
                                    global_cc_format) {
  standardGeneric("inner_col_df")
})

#' Column layout summary
#'
#' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a
#' `data.frame`.
#'
#' @inheritParams formatters::make_row_df
#' @param ccount_format (`FormatSpec`)\cr The format to be used by default for
#'   column counts if one is not specified for an individual column count.
#' @param na_str (`character(1)`)\cr The string to display when a column count is NA. Users should not need to set this.
#' @export
make_col_df <- function(tt,
                        colwidths = NULL,
                        visible_only = TRUE,
                        na_str = "",
                        ccount_format = colcount_format(tt) %||% "(N=xx)") {
  ctree <- coltree(tt, ccount_format = colcount_format(tt)) ## this is a null op if its already a coltree object
  rows <- inner_col_df(ctree,
    ## colwidths is currently unused anyway...  propose_column_widths(matrix_form(tt, indent_rownames=TRUE)),
    colwidths = colwidths,
    visible_only = visible_only,
    colnum = 1L,
    sibpos = 1L,
    nsibs = 1L,
    na_str = na_str,
    global_cc_format = ccount_format
  ) ## nsiblings includes current so 1 means "only child"

  do.call(rbind, rows)
}

setMethod(
  "inner_col_df", "LayoutColLeaf",
  function(ct, colwidths, visible_only,
           colnum,
           sibpos,
           nsibs,
           na_str,
           global_cc_format) {
    list(col_dfrow(
      col = ct,
      cnum = colnum,
      sibpos = sibpos,
      nsibs = nsibs,
      leaf_indices = colnum,
      col_fnotes = col_footnotes(ct),
      ccount_na_str = na_str,
      global_cc_format = global_cc_format
    ))
  }
)

setMethod(
  "inner_col_df", "LayoutColTree",
  function(ct, colwidths, visible_only,
           colnum,
           sibpos,
           nsibs,
           na_str,
           global_cc_format) {
    kids <- tree_children(ct)
    ret <- vector("list", length(kids))
    for (i in seq_along(kids)) {
      k <- kids[[i]]
      newrows <- do.call(
        rbind,
        inner_col_df(k,
          colnum = colnum,
          sibpos = i,
          nsibs = length(kids),
          visible_only = visible_only,
          na_str = na_str,
          global_cc_format = global_cc_format
        )
      )
      colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1
      ret[[i]] <- newrows
    }

    if (!visible_only) {
      allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)]))
      thispth <- pos_to_path(tree_pos(ct))
      if (any(nzchar(thispth))) {
        thisone <- list(col_dfrow(
          col = ct,
          cnum = NA_integer_,
          leaf_indices = allindices,
          sibpos = sibpos,
          nsibs = nsibs,
          pth = thispth,
          col_fnotes = col_footnotes(ct),
          ccount_na_str = na_str,
          global_cc_format = global_cc_format
        ))
        ret <- c(thisone, ret)
      }
    }

    ret
  }
)

## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND
## title/subtitle!!!!!
.header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
  cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
  if (any(nzchar(all_titles(tt)))) {
    ## +1 is for blank line between subtitles and divider
    tlines <- sum(nlines(all_titles(tt),
      colwidths = colwidths,
      max_width = max_width,
      fontspec = fontspec
    )) + divider_height(tt) + 1L
  } else {
    tlines <- 0
  }
  ret <- cinfo_lines + tlines
  if (verbose) {
    message(
      "Lines required for header content: ",
      ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")"
    )
  }
  ret
}

## this is ***only*** lines that are expected to be repeated on  multiple pages:
## main footer, prov footer, and referential footnotes on **columns**

.footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
  flines <- nlines(main_footer(tt),
    colwidths = colwidths,
    max_width = max_width - table_inset(tt),
    fontspec = fontspec
  ) +
    nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
  if (flines > 0) {
    dl_contrib <- if (have_cfnotes) 0 else divider_height(tt)
    flines <- flines + dl_contrib + 1L
  }

  if (verbose) {
    message(
      "Determining lines required for footer content",
      if (have_cfnotes) " [column fnotes present]",
      ": ", flines, " lines"
    )
  }

  flines
}

# Pagination ---------------------------------------------------------------

#' Pagination of a `TableTree`
#'
#' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size.
#'
#' @inheritParams gen_args
#' @inheritParams paginate_table
#' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows.
#' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a
#'   mid-subtable split to be valid. Defaults to 2.
#' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other
#'   considerations. Defaults to none.
#'
#' @return
#' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`.
#' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`.
#'
#' @details
#' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated
#' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the
#' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of
#' text than rendering the table without pagination would.
#'
#' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content.
#'
#' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`).
#'
#' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same
#' algorithm used for vertical pagination to it.
#'
#' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and
#' characters-per-page (`cpp`) values.
#'
#' The full multi-direction pagination algorithm then is as follows:
#'
#' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns):
#'   - titles/footers/column labels, and horizontal dividers in the vertical pagination case
#'   - row-labels, table_inset, and top-left materials in the horizontal case
#' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables.
#' 2. Perform vertical pagination separately on each table generated in (1).
#' 3. Perform horizontal pagination **on the entire table** and apply the results to each table
#'    page generated in (1)-(2).
#' 4. Return a list of subtables representing full bi-directional pagination.
#'
#' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package:
#'
#' @inheritSection formatters::pagination_algo Pagination Algorithm
#'
#' @examples
#' s_summary <- function(x) {
#'   if (is.numeric(x)) {
#'     in_rows(
#'       "n" = rcell(sum(!is.na(x)), format = "xx"),
#'       "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)),
#'         format = "xx.xx (xx.xx)"
#'       ),
#'       "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"),
#'       "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx")
#'     )
#'   } else if (is.factor(x)) {
#'     vs <- as.list(table(x))
#'     do.call(in_rows, lapply(vs, rcell, format = "xx"))
#'   } else {
#'     (
#'       stop("type not supported")
#'     )
#'   }
#' }
#'
#' lyt <- basic_table() %>%
#'   split_cols_by(var = "ARM") %>%
#'   analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' nrow(tbl)
#'
#' row_paths_summary(tbl)
#'
#' tbls <- paginate_table(tbl, lpp = 15)
#' mf <- matrix_form(tbl, indent_rownames = TRUE)
#' w_tbls <- propose_column_widths(mf) # so that we have the same column widths
#'
#'
#' tmp <- lapply(tbls, function(tbli) {
#'   cat(toString(tbli, widths = w_tbls))
#'   cat("\n\n")
#'   cat("~~~~ PAGE BREAK ~~~~")
#'   cat("\n\n")
#' })
#'
#' @rdname paginate
#' @export
pag_tt_indices <- function(tt,
                           lpp = 15,
                           min_siblings = 2,
                           nosplitin = character(),
                           colwidths = NULL,
                           max_width = NULL,
                           fontspec = NULL,
                           col_gap = 3,
                           verbose = FALSE) {
  dheight <- divider_height(tt)

  #  cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width)
  coldf <- make_col_df(tt, colwidths)
  have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0

  hlines <- .header_rep_nlines(tt,
    colwidths = colwidths, max_width = max_width,
    verbose = verbose,
    fontspec = fontspec
  )
  ## if(any(nzchar(all_titles(tt)))) {
  ##     tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) +
  ##       length(wrap_txt(all_titles(tt), max_width = max_width)) +
  ##         dheight + 1L
  ## } else {
  ##     tlines <- 0
  ## }
  ## flines <- nlines(main_footer(tt), colwidths = colwidths,
  ##                  max_width = max_width - table_inset(tt)) +
  ##     nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width)
  ## if(flines > 0) {
  ##     dl_contrib <- if(have_cfnotes) 0 else dheight
  ##     flines <- flines + dl_contrib + 1L
  ## }
  flines <- .footer_rep_nlines(tt,
    colwidths = colwidths,
    max_width = max_width,
    have_cfnotes = have_cfnotes,
    fontspec = fontspec,
    verbose = verbose
  )
  ## row lines per page
  rlpp <- lpp - hlines - flines
  if (verbose) {
    message(
      "Adjusted Lines Per Page: ",
      rlpp, " (original lpp: ", lpp, ")"
    )
  }
  pagdf <- make_row_df(tt, colwidths, max_width = max_width)

  pag_indices_inner(pagdf,
    rlpp = rlpp, min_siblings = min_siblings,
    nosplitin = nosplitin,
    verbose = verbose,
    have_col_fnotes = have_cfnotes,
    div_height = dheight,
    col_gap = col_gap,
    has_rowlabels = TRUE
  )
}

copy_title_footer <- function(to, from, newptitle) {
  main_title(to) <- main_title(from)
  subtitles(to) <- subtitles(from)
  page_titles(to) <- c(page_titles(from), newptitle)
  main_footer(to) <- main_footer(from)
  prov_footer(to) <- prov_footer(from)
  to
}

pag_btw_kids <- function(tt) {
  pref <- ptitle_prefix(tt)
  lapply(
    tree_children(tt),
    function(tbl) {
      tbl <- copy_title_footer(
        tbl, tt,
        paste(pref, obj_label(tbl), sep = ": ")
      )
      labelrow_visible(tbl) <- FALSE
      tbl
    }
  )
}

force_paginate <- function(tt,
                           force_pag = vapply(tree_children(tt), has_force_pag, NA),
                           verbose = FALSE) {
  ## forced pagination is happening at this
  if (has_force_pag(tt)) {
    ret <- pag_btw_kids(tt)
    return(unlist(lapply(ret, force_paginate)))
  }
  chunks <- list()
  kinds <- seq_along(force_pag)
  while (length(kinds) > 0) {
    if (force_pag[kinds[1]]) {
      outertbl <- copy_title_footer(
        tree_children(tt)[[kinds[1]]],
        tt,
        NULL
      )

      chunks <- c(chunks, force_paginate(outertbl))
      kinds <- kinds[-1]
    } else {
      tmptbl <- tt
      runend <- min(which(force_pag[kinds]), length(kinds))
      useinds <- 1:runend
      tree_children(tmptbl) <- tree_children(tt)[useinds]
      chunks <- c(chunks, tmptbl)
      kinds <- kinds[-useinds]
    }
  }
  unlist(chunks, recursive = TRUE)
}

#' @importFrom formatters do_forced_paginate
setMethod(
  "do_forced_paginate", "VTableTree",
  function(obj) force_paginate(obj)
)

non_null_na <- function(x) !is.null(x) && is.na(x)

#' @inheritParams formatters::vert_pag_indices
#' @inheritParams formatters::page_lcpp
#' @inheritParams formatters::toString
#' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination.
#'   `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal
#'   pagination should be done regardless of page size.
#'
#' @rdname paginate
#' @aliases paginate_table
#' @export
paginate_table <- function(tt,
                           page_type = "letter",
                           font_family = "Courier",
                           font_size = 8,
                           lineheight = 1,
                           landscape = FALSE,
                           pg_width = NULL,
                           pg_height = NULL,
                           margins = c(top = .5, bottom = .5, left = .75, right = .75),
                           lpp = NA_integer_,
                           cpp = NA_integer_,
                           min_siblings = 2,
                           nosplitin = character(),
                           colwidths = NULL,
                           tf_wrap = FALSE,
                           max_width = NULL,
                           fontspec = font_spec(font_family, font_size, lineheight),
                           col_gap = 3,
                           verbose = FALSE) {
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }

  if ((non_null_na(lpp) || non_null_na(cpp)) &&
    (!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
    pg_lcpp <- page_lcpp(
      page_type = page_type,
      font_family = font_family,
      font_size = font_size,
      lineheight = lineheight,
      pg_width = pg_width,
      pg_height = pg_height,
      margins = margins,
      landscape = landscape,
      fontspec = fontspec
    )

    if (non_null_na(lpp)) {
      lpp <- pg_lcpp$lpp
    }
    if (is.na(cpp)) {
      cpp <- pg_lcpp$cpp
    }
  } else {
    if (non_null_na(cpp)) {
      cpp <- NULL
    }
    if (non_null_na(lpp)) {
      lpp <- 70
    }
  }

  if (is.null(colwidths)) {
    colwidths <- propose_column_widths(
      matrix_form(
        tt,
        indent_rownames = TRUE,
        fontspec = fontspec,
        col_gap = col_gap
      ),
      fontspec = fontspec
    )
  }

  if (!tf_wrap) {
    if (!is.null(max_width)) {
      warning("tf_wrap is FALSE - ignoring non-null max_width value.")
    }
    max_width <- NULL
  } else if (is.null(max_width)) {
    max_width <- cpp
  } else if (identical(max_width, "auto")) {
    ## XXX this 3 is column sep width!!!!!!!
    max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1)
  }
  if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
    warning("max_width specified is wider than characters per page width (cpp).")
  }

  ## taken care of in vert_pag_indices now
  ## if(!is.null(cpp))
  ##     cpp <- cpp - table_inset(tt)

  force_pag <- vapply(tree_children(tt), has_force_pag, TRUE)
  if (has_force_pag(tt) || any(force_pag)) {
    spltabs <- do_forced_paginate(tt)
    spltabs <- unlist(spltabs, recursive = TRUE)
    ret <- lapply(spltabs, paginate_table,
      lpp = lpp,
      cpp = cpp,
      min_siblings = min_siblings,
      nosplitin = nosplitin,
      colwidths = colwidths,
      tf_wrap = tf_wrap,
      max_width = max_width,
      fontspec = fontspec,
      verbose = verbose,
      col_gap = col_gap
    )
    return(unlist(ret, recursive = TRUE))
  }

  inds <- paginate_indices(tt,
    page_type = page_type,
    fontspec = fontspec,
    ## font_family = font_family,
    ## font_size = font_size,
    ## lineheight = lineheight,
    landscape = landscape,
    pg_width = pg_width,
    pg_height = pg_height,
    margins = margins,
    lpp = lpp,
    cpp = cpp,
    min_siblings = min_siblings,
    nosplitin = nosplitin,
    colwidths = colwidths,
    tf_wrap = tf_wrap,
    max_width = max_width,
    col_gap = col_gap,
    verbose = verbose
  ) ## paginate_table apparently doesn't accept indent_size

  res <- lapply(
    inds$pag_row_indices,
    function(ii) {
      subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]
      lapply(
        inds$pag_col_indices,
        function(jj) {
          subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]
        }
      )
    }
  )
  res <- unlist(res, recursive = FALSE)
  res
}

#' Format `rcell` objects
#'
#' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects
#'
#' @inheritParams lyt_args
#' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value.
#' @param format (`string` or `function`)\cr the format label or formatter function to
#'   apply to `x`.
#' @param output (`string`)\cr output type.
#' @param pr_row_format (`list`)\cr list of default formats coming from the general row.
#' @param pr_row_na_str (`list`)\cr list of default `"NA"` strings coming from the general row.
#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the
#'   values with formats applied. Defaults to `FALSE`.
#'
#' @return Formatted text.
#'
#' @examples
#' cll <- CellValue(pi, format = "xx.xxx")
#' format_rcell(cll)
#'
#' # Cell values precedes the row values
#' cll <- CellValue(pi, format = "xx.xxx")
#' format_rcell(cll, pr_row_format = "xx.x")
#'
#' # Similarly for NA values
#' cll <- CellValue(NA, format = "xx.xxx", format_na_str = "This is THE NA")
#' format_rcell(cll, pr_row_na_str = "This is NA")
#'
#' @export
format_rcell <- function(x, format,
                         output = c("ascii", "html"),
                         na_str = obj_na_str(x) %||% "NA",
                         pr_row_format = NULL,
                         pr_row_na_str = NULL,
                         shell = FALSE) {
  # Check for format and parent row format
  format <- if (missing(format)) obj_format(x) else format
  if (is.null(format) && !is.null(pr_row_format)) {
    format <- pr_row_format
  }
  # Check for na_str from parent
  if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
    na_str <- pr_row_na_str
  }

  # Main call to external function or shell
  if (shell) {
    return(format)
  }
  format_value(rawvalues(x),
    format = format,
    output = output,
    na_str = na_str
  )
}

insert_brs <- function(vec) {
  if (length(vec) == 1) {
    ret <- list(vec)
  } else {
    nout <- length(vec) * 2 - 1
    ret <- vector("list", nout)
    for (i in seq_along(vec)) {
      ret[[2 * i - 1]] <- vec[i]
      if (2 * i < nout) {
        ret[[2 * i]] <- tags$br()
      }
    }
  }
  ret
}

div_helper <- function(lst, class) {
  do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst)))
}

#' Convert an `rtable` object to a `shiny.tag` HTML object
#'
#' The returned HTML object can be immediately used in `shiny` and `rmarkdown`.
#'
#' @param x (`VTableTree`)\cr a `TableTree` object.
#' @param class_table (`character`)\cr class for `table` tag.
#' @param class_tr (`character`)\cr class for `tr` tag.
#' @param class_th (`character`)\cr class for `th` tag.
#' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a
#'   percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`.
#' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table.
#' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`,
#'   `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label
#'   rows). Defaults to `"header"`.
#' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults
#'   to `TRUE`.
#' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults
#'   to `FALSE`.
#' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`).
#'   Doing this keeps the structure of the cells but may depend on the output device.
#'
#' @importFrom htmltools tags
#'
#' @return A `shiny.tag` object representing `x` in HTML.
#'
#' @examples
#' tbl <- rtable(
#'   header = LETTERS[1:3],
#'   format = "xx",
#'   rrow("r1", 1, 2, 3),
#'   rrow("r2", 4, 3, 2, indent = 1),
#'   rrow("r3", indent = 2)
#' )
#'
#' as_html(tbl)
#'
#' as_html(tbl, class_table = "table", class_tr = "row")
#'
#' as_html(tbl, bold = c("header", "row_names"))
#'
#' \dontrun{
#' Viewer(tbl)
#' }
#'
#' @export
as_html <- function(x,
                    width = NULL,
                    class_table = "table table-condensed table-hover",
                    class_tr = NULL,
                    class_th = NULL,
                    link_label = NULL,
                    bold = c("header"),
                    header_sep_line = TRUE,
                    no_spaces_between_cells = FALSE,
                    expand_newlines = FALSE) {
  if (is.null(x)) {
    return(tags$p("Empty Table"))
  }

  stopifnot(is(x, "VTableTree"))

  mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines)

  nlh <- mf_nlheader(mat)
  nc <- ncol(x) + 1
  nr <- length(mf_lgrouping(mat))

  # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions
  cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc)

  for (i in seq_len(nr)) {
    for (j in seq_len(nc)) {
      curstrs <- mf_strings(mat)[i, j]
      curspn <- mf_spans(mat)[i, j]
      algn <- mf_aligns(mat)[i, j]

      inhdr <- i <= nlh
      tagfun <- if (inhdr) tags$th else tags$td
      cells[i, j][[1]] <- tagfun(
        class = if (inhdr) class_th else class_tr,
        style = paste0("text-align: ", algn, ";"),
        style = if (inhdr && !"header" %in% bold) "font-weight: normal;",
        style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;",
        colspan = if (curspn != 1) curspn,
        insert_brs(curstrs)
      )
    }
  }

  if (header_sep_line) {
    cells[nlh][[1]] <- htmltools::tagAppendAttributes(
      cells[nlh, 1][[1]],
      style = "border-bottom: 1px solid black;"
    )
  }

  # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh
  map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping)
  row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh)
  map <- merge(map, row_info_df, by = "abs_rownumber")

  # add indent values for headerlines
  map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map)


  # Row labels style
  for (i in seq_len(nr)) {
    indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1)

    # Apply indentation
    if (indent > 0) {
      cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
        cells[i, 1][[1]],
        style = paste0("padding-left: ", indent * 3, "ch;")
      )
    }

    # Apply bold font weight if "row_names" is in 'bold'
    if ("row_names" %in% bold) {
      cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
        cells[i, 1][[1]],
        style = "font-weight: bold;"
      )
    }
  }

  # label rows style
  if ("label_rows" %in% bold) {
    which_lbl_rows <- which(mat$row_info$node_class == "LabelRow")
    cells[which_lbl_rows + nlh, ] <- lapply(
      cells[which_lbl_rows + nlh, ],
      htmltools::tagAppendAttributes,
      style = "font-weight: bold;"
    )
  }

  # content rows style
  if ("content_rows" %in% bold) {
    which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
    cells[which_cntnt_rows + nlh, ] <- lapply(
      cells[which_cntnt_rows + nlh, ],
      htmltools::tagAppendAttributes,
      style = "font-weight: bold;"
    )
  }

  if (any(!mat$display)) {
    # Check that expansion kept the same display info
    check_expansion <- c()
    for (ii in unique(mat$line_grouping)) {
      rows <- which(mat$line_grouping == ii)
      check_expansion <- c(
        check_expansion,
        apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x))
      )
    }

    if (!all(check_expansion)) {
      stop(
        "Found that a group of rows have different display options even if ",
        "they belong to the same line group. This should not happen. Please ",
        "file an issue or report to the maintainers."
      ) # nocov
    }

    for (ii in unique(mat$line_grouping)) {
      rows <- which(mat$line_grouping == ii)
      should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)
      cells[ii, !should_display_col] <- NA_integer_
    }
  }

  rows <- apply(cells, 1, function(row) {
    tags$tr(
      class = class_tr,
      style = "white-space: pre;",
      Filter(function(x) !identical(x, NA_integer_), row)
    )
  })

  hsep_line <- tags$hr(class = "solid")

  hdrtag <- div_helper(
    class = "rtables-titles-block",
    list(
      div_helper(
        class = "rtables-main-titles-block",
        lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
          class = "rtables-main-title"
        )
      ),
      div_helper(
        class = "rtables-subtitles-block",
        lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
          class = "rtables-subtitle"
        )
      )
    )
  )

  tabletag <- do.call(
    tags$table,
    c(
      rows,
      list(
        class = class_table,
        style = paste(
          if (no_spaces_between_cells) "border-collapse: collapse;",
          if (!is.null(width)) paste("width:", width)
        ),
        tags$caption(sprintf("(\\#tag:%s)", link_label),
          style = "caption-side: top;",
          .noWS = "after-begin"
        )
      )
    )
  )

  rfnotes <- div_helper(
    class = "rtables-ref-footnotes-block",
    lapply(mat$ref_footnotes, tags$p,
      class = "rtables-referential-footnote"
    )
  )

  mftr <- div_helper(
    class = "rtables-main-footers-block",
    lapply(main_footer(x), tags$p,
      class = "rtables-main-footer"
    )
  )

  pftr <- div_helper(
    class = "rtables-prov-footers-block",
    lapply(prov_footer(x), tags$p,
      class = "rtables-prov-footer"
    )
  )

  ## XXX this omits the divs entirely if they are empty. Do we want that or do
  ## we want them to be there but empty??
  ftrlst <- list(
    if (length(mat$ref_footnotes) > 0) rfnotes,
    if (length(mat$ref_footnotes) > 0) hsep_line,
    if (length(main_footer(x)) > 0) mftr,
    if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break
    if (length(prov_footer(x)) > 0) pftr
  )

  if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst)
  ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)]

  ftrtag <- div_helper(
    class = "rtables-footers-block",
    ftrlst
  )

  div_helper(
    class = "rtables-all-parts-block",
    list(
      hdrtag,
      tabletag,
      ftrtag
    )
  )
}

#' Find degenerate (sub)structures within a table
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if
#' they have associated content rows).
#'
#' @param tt (`TableTree`)\cr a `TableTree` object.
#'
#' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table.
#'
#' @examples
#' find_degen_struct(rtable("hi"))
#'
#' @family table structure validation functions
#' @export
find_degen_struct <- function(tt) {
  degen <- list()

  recurse_check <- function(tti, path) {
    if (is(tti, "VTableTree")) {
      kids <- tree_children(tti)
      if (length(kids) == 0) {
        degen <<- c(degen, list(path))
      } else {
        for (i in seq_along(kids)) {
          recurse_check(kids[[i]], path = c(path, names(kids)[i]))
        }
      }
    }
  }
  recurse_check(tt, obj_name(tt) %||% "root")
  degen
}

#' Validate and assert valid table structure
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A `TableTree` (`rtables`-built table) is considered degenerate if:
#' \enumerate{
#'   \item{It contains no subtables or data rows (content rows do not count).}
#'   \item{It contains a subtable which is degenerate by the criterion above.}
#' }
#'
#' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure.
#'
#' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or
#' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more
#' invalid substructures.
#'
#' @param tt (`TableTree`)\cr a `TableTree` object.
#'
#' @return
#' * `validate_table_struct` returns a logical value indicating valid structure.
#' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables.
#'
#' @note This function is experimental and the exact text of the warning/error is subject to change in future releases.
#'
#' @examples
#' validate_table_struct(rtable("hahaha"))
#' \dontrun{
#' assert_valid_table(rtable("oops"))
#' }
#'
#' @family table structure validation functions
#' @export
validate_table_struct <- function(tt) {
  degen_pths <- find_degen_struct(tt)
  length(degen_pths) == 0
}

## XXX this doesn't handle content paths correctly
.path_to_disp <- function(pth) {
  if (length(pth) == 1) {
    return(pth)
  }
  has_cont <- any(pth == "@content")
  if (has_cont) {
    contpos <- which(pth == "@content")
    cont_disp <- paste(tail(pth, length(pth) - contpos + 1),
      collapse = "->"
    )
    pth <- head(pth, contpos)
  } else {
    cont_disp <- character()
  }

  topaste <- character(0)
  fullpth <- pth
  while (length(pth) > 0) {
    if (length(pth) <= 1) {
      topaste <- c(topaste, pth)
      pth <- character()
    } else {
      topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
      pth <- tail(pth, -2)
    }
  }
  topaste <- c(topaste, cont_disp)
  paste(topaste, collapse = "->")
}

no_analyze_guess <- paste0(
  "Was this table created using ",
  "summarize_row_groups but no calls ",
  "to analyze?\n"
)

use_sanitize_msg <- paste("  Use sanitize_table_struct() to fix these issues")

make_degen_message <- function(degen_pths, tt) {
  msg <- sprintf(
    paste0(
      "Invalid table - found %d (sub)structures which contain no data rows.",
      "\n\tThe first occured at path:  %s"
    ),
    length(degen_pths), .path_to_disp(degen_pths[[1]])
  )
  if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
    msg <- paste(msg, "  Likely Cause: Empty data or first row split on variable with only NA values",
      sep = "\n"
    )
  } else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
    msg <- paste(msg, "  Cause: Layout did not contain any analyze() calls (only summarize_row_groups())",
      sep = "\n"
    )
  }
  msg <- paste(msg, use_sanitize_msg, sep = "\n")
  msg
}

#' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`.
#'
#' @rdname validate_table_struct
#' @export
assert_valid_table <- function(tt, warn_only = FALSE) {
  degen_pths <- find_degen_struct(tt)
  if (length(degen_pths) == 0) {
    return(TRUE)
  }

  ## we failed, now we build an informative error/warning message
  msg <- make_degen_message(degen_pths, tt)

  if (!warn_only) {
    stop(msg)
  }
  warning(msg)
  return(FALSE)
}

#' Sanitize degenerate table structures
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures.
#'
#' @param tt (`TableTree`)\cr a `TableTree` object.
#' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows.
#'
#' @details
#' This function locates degenerate portions of the table (including the table overall in the case of a table with no
#' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table
#' guaranteed to be non-degenerate.
#'
#' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate
#' version of the table is returned.
#'
#' @examples
#' sanitize_table_struct(rtable("cool beans"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups()
#'
#' ## Degenerate because it doesn't have any analyze calls -> no data rows
#' badtab <- build_table(lyt, DM)
#' sanitize_table_struct(badtab)
#'
#' @family table structure validation functions
#' @export
sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
  rdf <- make_row_df(tt)

  emptyrow <- DataRow(
    vals = list(empty_msg),
    name = "empty_section",
    label = "",
    cspan = ncol(tt),
    cinfo = col_info(tt),
    format = "xx",
    table_inset = table_inset(tt)
  )
  degen_pths <- find_degen_struct(tt)

  if (identical(degen_pths, list("root"))) {
    tree_children(tt) <- list(empty_row = emptyrow)
    return(tt)
  }

  for (pth in degen_pths) {
    ## FIXME this shouldn't be necessary. why is it?
    tti <- tt_at_path(tt, path = pth)
    tree_children(tti) <- list(empty_section = emptyrow)
    tt_at_path(tt, path = pth) <- tti
  }
  tt
}

#' Trimming and pruning criteria
#'
#' Criteria functions (and constructors thereof) for trimming and pruning tables.
#'
#' @inheritParams gen_args
#'
#' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning.
#'
#' @seealso [prune_table()], [trim_rows()]
#'
#' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any *non-`LabelRow`*
#'   `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values.
#'
#' @examples
#' adsl <- ex_adsl
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
#' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0
#' adsl$BMRKR1 <- 0
#'
#' tbl_to_prune <- basic_table() %>%
#'   analyze("BMRKR1") %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE") %>%
#'   build_table(adsl)
#'
#' tbl_to_prune %>% prune_table(all_zero_or_na)
#'
#' @rdname trim_prune_funs
#' @export
all_zero_or_na <- function(tr) {
  if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
    return(FALSE)
  }
  rvs <- unlist(unname(row_values(tr)))
  all(is.na(rvs) | rvs == 0 | !is.finite(rvs))
}

#' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values.
#'
#' @examples
#' tbl_to_prune %>% prune_table(all_zero)
#'
#' @rdname trim_prune_funs
#' @export
all_zero <- function(tr) {
  if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
    return(FALSE)
  }
  rvs <- unlist(unname(row_values(tr)))
  isTRUE(all(rvs == 0))
}

#' Trim rows from a populated table without regard for table structure
#'
#' @inheritParams gen_args
#' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row
#'   should be removed. Defaults to [all_zero_or_na()].
#'
#' @return The table with rows that have only `NA` or 0 cell values removed.
#'
#' @note
#' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or
#' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on
#' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead.
#'
#' @details
#' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()]
#' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure
#' into account.
#'
#' @seealso [prune_table()]
#'
#' @examples
#' adsl <- ex_adsl
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
#'
#' tbl_to_trim <- basic_table() %>%
#'   analyze("BMRKR1") %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE") %>%
#'   build_table(adsl)
#'
#' tbl_to_trim %>% trim_rows()
#'
#' tbl_to_trim %>% trim_rows(all_zero)
#'
#' @export
trim_rows <- function(tt, criteria = all_zero_or_na) {
  rows <- collect_leaves(tt, TRUE, TRUE)
  torm <- vapply(rows, criteria,
    NA,
    USE.NAMES = FALSE
  )
  tt[!torm, ,
    keep_topleft = TRUE,
    keep_titles = TRUE,
    keep_footers = TRUE,
    reindex_refs = TRUE
  ]
}

#' @inheritParams trim_rows
#'
#' @details
#' `content_all_zeros_nas` prunes a subtable if both of the following are true:
#'
#'   * It has a content table with exactly one row in it.
#'   * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content
#'     function is used, this represents pruning any subtable which corresponds to an empty set of the input data
#'     (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data).
#'
#' @examples
#' tbl_to_prune %>% prune_table(content_all_zeros_nas)
#'
#' @rdname trim_prune_funs
#' @export
content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
  ## this will be NULL if
  ## tt is something that doesn't have a content table
  ct <- content_table(tt)
  ## NROW returns 0 for NULL.
  if (NROW(ct) == 0 || nrow(ct) > 1) {
    return(FALSE)
  }

  cr <- tree_children(ct)[[1]]
  criteria(cr)
}

#' @details
#' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on
#' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no
#' children.
#'
#' @examples
#' tbl_to_prune %>% prune_table(prune_empty_level)
#'
#' @rdname trim_prune_funs
#' @export
prune_empty_level <- function(tt) {
  if (is(tt, "TableRow")) {
    return(all_zero_or_na(tt))
  }

  if (content_all_zeros_nas(tt)) {
    return(TRUE)
  }
  kids <- tree_children(tt)
  length(kids) == 0
}

#' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes
#'   only in the case of all non-missing zero values.
#'
#' @examples
#' tbl_to_prune %>% prune_table(prune_zeros_only)
#'
#' @rdname trim_prune_funs
#' @export
prune_zeros_only <- function(tt) {
  if (is(tt, "TableRow")) {
    return(all_zero(tt))
  }

  if (content_all_zeros_nas(tt, criteria = all_zero)) {
    return(TRUE)
  }
  kids <- tree_children(tt)
  length(kids) == 0
}

#' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value.
#'   Subtables whose combined/average count are below this threshold will be pruned.
#' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`.
#'
#' @details
#' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which
#' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell
#' values (defined as the first value per cell regardless of how many values per cell there are) against `min`.
#'
#' @examples
#' min_prune <- low_obs_pruner(70, "sum")
#' tbl_to_prune %>% prune_table(min_prune)
#'
#' @rdname trim_prune_funs
#' @export
low_obs_pruner <- function(min, type = c("sum", "mean")) {
  type <- match.arg(type)
  function(tt) {
    if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
      return(FALSE) ## only trimming on count content rows
    }
    ctr <- tree_children(ctab)[[1]]
    vals <- sapply(row_values(ctr), function(v) v[[1]])
    sumvals <- sum(vals)
    if (type == "mean") {
      sumvals <- sumvals / length(vals)
    }
    sumvals < min
  }
}

#' Recursively prune a `TableTree`
#'
#' @inheritParams gen_args
#' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the
#'   entire subtree should be removed.
#' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.
#'   Defaults to `NA` which indicates pruning should happen at all levels.
#' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.
#'
#' @return A `TableTree` pruned via recursive application of `prune_func`.
#'
#' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included
#'   in the `rtables` package.
#'
#' @examples
#' adsl <- ex_adsl
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
#'
#' tbl_to_prune <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE") %>%
#'   build_table(adsl)
#'
#' tbl_to_prune %>% prune_table()
#'
#' @export
prune_table <- function(tt,
                        prune_func = prune_empty_level,
                        stop_depth = NA_real_,
                        depth = 0) {
  if (!is.na(stop_depth) && depth > stop_depth) {
    return(tt)
  }
  if (is(tt, "TableRow")) {
    if (prune_func(tt)) {
      tt <- NULL
    }
    return(tt)
  }

  kids <- tree_children(tt)

  torm <- vapply(kids, function(tb) {
    !is.null(tb) && prune_func(tb)
  }, NA)

  keepkids <- kids[!torm]
  keepkids <- lapply(keepkids, prune_table,
    prune_func = prune_func,
    stop_depth = stop_depth,
    depth = depth + 1
  )

  keepkids <- keepkids[!vapply(keepkids, is.null, NA)]
  if (length(keepkids) > 0) {
    tree_children(tt) <- keepkids
  } else {
    tt <- NULL
  }
  tt
}

#' Cell value constructors
#'
#' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.
#'
#' @inheritParams compat_args
#' @inheritParams lyt_args
#' @param x (`ANY`)\cr cell value.
#' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.
#'   See [formatters::list_valid_format_labels()] for currently supported format labels.
#' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.
#' @param colspan (`integer(1)`)\cr column span value.
#' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.
#'
#' @inherit CellValue return
#'
#' @note Currently column spanning is only supported for defining header structure.
#'
#' @rdname rcell
#' @export
rcell <- function(x,
                  format = NULL,
                  colspan = 1L,
                  label = NULL,
                  indent_mod = NULL,
                  footnotes = NULL,
                  align = NULL,
                  format_na_str = NULL) {
  if (!is.null(align)) {
    check_aligns(align)
  }
  if (is(x, "CellValue")) {
    if (!is.null(label)) {
      obj_label(x) <- label
    }
    if (colspan != 1L) {
      cell_cspan(x) <- colspan
    }
    if (!is.null(indent_mod)) {
      indent_mod(x) <- indent_mod
    }
    if (!is.null(format)) {
      obj_format(x) <- format
    }
    if (!is.null(footnotes)) {
      cell_footnotes(x) <- lapply(footnotes, RefFootnote)
    }
    if (!is.null(format_na_str)) {
      obj_na_str(x) <- format_na_str
    }
    ret <- x
  } else {
    if (is.null(label)) {
      label <- obj_label(x)
    }
    if (is.null(format)) {
      format <- obj_format(x)
    }
    if (is.null(indent_mod)) {
      indent_mod <- indent_mod(x)
    }
    footnotes <- lapply(footnotes, RefFootnote)
    ret <- CellValue(
      val = x,
      format = format,
      colspan = colspan,
      label = label,
      indent_mod = indent_mod,
      footnotes = footnotes,
      format_na_str = format_na_str
    ) # RefFootnote(footnote))
  }
  if (!is.null(align)) {
    cell_align(ret) <- align
  }
  ret
}

#' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be
#'   passed to this argument).
#' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.
#'
#' @details
#' `non_ref_rcell` provides the common *blank for cells in the reference column, this value otherwise*, and should
#' be passed the value of `.in_ref_col` when it is used.
#'
#' @rdname rcell
#' @export
non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,
                          label = NULL, indent_mod = NULL,
                          refval = NULL,
                          align = "center",
                          format_na_str = NULL) {
  val <- if (is_ref) refval else x
  rcell(val,
    format = format, colspan = colspan, label = label,
    indent_mod = indent_mod, align = align,
    format_na_str = format_na_str
  )
}

#' Create multiple rows in analysis or summary functions
#'
#' Define the cells that get placed into multiple rows in `afun`.
#'
#' @param ... single row defining expressions.
#' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.
#' @param .names (`character` or `NULL`)\cr names of the returned list/structure.
#' @param .labels (`character` or `NULL`)\cr labels for the defined rows.
#' @param .formats (`character` or `NULL`)\cr formats for the values.
#' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.
#' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with *cells*.
#' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with *rows*.
#' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.
#'   See [formatters::list_valid_aligns()] for currently supported alignments.
#' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.
#'
#' @note In post-processing, referential footnotes can also be added using row and column
#'   paths with [`fnotes_at_path<-`].
#'
#' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an
#'   internal implementation detail.
#'
#' @seealso [analyze()]
#'
#' @examples
#' in_rows(1, 2, 3, .names = c("a", "b", "c"))
#' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
#' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
#'
#' in_rows(.list = list(a = 1, b = 2, c = 3))
#' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze("AGE", afun = function(x) {
#'     in_rows(
#'       "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
#'       "Range" = rcell(range(x), format = "xx.xx - xx.xx")
#'     )
#'   })
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' @export
in_rows <- function(..., .list = NULL, .names = NULL,
                    .labels = NULL,
                    .formats = NULL,
                    .indent_mods = NULL,
                    .cell_footnotes = list(NULL),
                    .row_footnotes = list(NULL),
                    .aligns = NULL,
                    .format_na_strs = NULL) {
  if (is.function(.formats)) {
    .formats <- list(.formats)
  }

  l <- c(list(...), .list)

  if (missing(.names) && missing(.labels)) {
    if (length(l) > 0 && is.null(names(l))) {
      stop("need a named list")
    } else {
      .names <- names(l)
    }
    stopifnot(!anyNA(.names))
  }

  if (length(l) == 0) {
    if (
      length(.labels) > 0 ||
        length(.formats) > 0 ||
        length(.names) > 0 ||
        length(.indent_mods) > 0 ||
        length(.format_na_strs) > 0
    ) {
      stop(
        "in_rows got 0 rows but length >0 of at least one of ",
        ".labels, .formats, .names, .indent_mods, .format_na_strs. ",
        "Does your analysis/summary function handle the 0 row ",
        "df/length 0 x case?"
      )
    }
    l2 <- list()
  } else {
    if (is.null(.formats)) {
      .formats <- list(NULL)
    }
    stopifnot(is.list(.cell_footnotes))
    if (length(.cell_footnotes) != length(l)) {
      .cell_footnotes <- c(
        .cell_footnotes,
        setNames(
          rep(list(character()),
            length.out = length(setdiff(
              names(l),
              names(.cell_footnotes)
            ))
          ),
          setdiff(
            names(l),
            names(.cell_footnotes)
          )
        )
      )
      .cell_footnotes <- .cell_footnotes[names(l)]
    }
    if (is.null(.aligns)) {
      .aligns <- list(NULL)
    }
    l2 <- mapply(rcell,
      x = l, format = .formats,
      footnotes = .cell_footnotes %||% list(NULL),
      align = .aligns,
      format_na_str = .format_na_strs %||% list(NULL),
      SIMPLIFY = FALSE
    )
  }
  if (is.null(.labels)) {
    objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "")
    if (any(nzchar(objlabs))) {
      .labels <- objlabs
    }
  }

  if (is.null(.names) && !is.null(names(l))) {
    .names <- names(l)
  }
  stopifnot(is.list(.row_footnotes))
  if (length(.row_footnotes) != length(l2)) {
    tmp <- .row_footnotes
    .row_footnotes <- vector("list", length(l2))
    pos <- match(names(tmp), .names)
    nonna <- which(!is.na(pos))
    .row_footnotes[pos] <- tmp[nonna]
    #        length(.row_footnotes) <- length(l2)
  }
  ret <- RowsVerticalSection(l2,
    names = .names,
    labels = .labels,
    indent_mods = .indent_mods,
    formats = .formats,
    footnotes = .row_footnotes,
    format_na_strs = .format_na_strs
  )
  ## if(!is.null(.names))
  ##     names(l2) <- .names
  ## else
  ##     names(l2) <- names(l)
  if (length(ret) == 0) NULL else ret

  ##   if (length(l) == 0) NULL else l
}

.validate_nms <- function(vals, .stats, arg) {
  if (!is.null(arg)) {
    if (is.null(names(arg))) {
      stopifnot(length(arg) == length(.stats))
      names(arg) <- names(vals)
    } else {
      lblpos <- match(names(arg), names(vals))
      stopifnot(!anyNA(lblpos))
    }
  }
  arg
}

#' Create a custom analysis function wrapping an existing function
#'
#' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.
#'   `fun` should return a named `list`.
#' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.
#' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.
#' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.
#' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.
#' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.
#' @param ... additional arguments to `fun` which effectively become new defaults. These can still be
#'   overridden by `extra_args` within a split.
#' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the
#'   returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note
#'   this argument occurs after `...` so it must be *fully* specified by name when set.
#' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.
#'
#' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling
#'   performed automatically.
#'
#' @note
#' Setting `.ungroup_stats` to non-`NULL` changes the *structure* of the value(s) returned by `fun`, rather than
#' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that
#' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,
#' *not* the original structure returned by `fun`. See the final pair of examples below.
#'
#' @seealso [analyze()]
#'
#' @examples
#' s_summary <- function(x) {
#'   stopifnot(is.numeric(x))
#'
#'   list(
#'     n = sum(!is.na(x)),
#'     mean_sd = c(mean = mean(x), sd = sd(x)),
#'     min_max = range(x)
#'   )
#' }
#'
#' s_summary(iris$Sepal.Length)
#'
#' a_summary <- make_afun(
#'   fun = s_summary,
#'   .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),
#'   .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")
#' )
#'
#' a_summary(x = iris$Sepal.Length)
#'
#' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
#'
#' a_summary2(x = iris$Sepal.Length)
#'
#' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))
#'
#' s_foo <- function(df, .N_col, a = 1, b = 2) {
#'   list(
#'     nrow_df = nrow(df),
#'     .N_col = .N_col,
#'     a = a,
#'     b = b
#'   )
#' }
#'
#' s_foo(iris, 40)
#'
#' a_foo <- make_afun(s_foo,
#'   b = 4,
#'   .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),
#'   .labels = c(
#'     nrow_df = "Nrow df",
#'     ".N_col" = "n in cols", a = "a value", b = "b value"
#'   ),
#'   .indent_mods = c(nrow_df = 2L, a = 1L)
#' )
#'
#' a_foo(iris, .N_col = 40)
#' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))
#' a_foo2(iris, .N_col = 40)
#'
#' # grouping and further customization
#' s_grp <- function(df, .N_col, a = 1, b = 2) {
#'   list(
#'     nrow_df = nrow(df),
#'     .N_col = .N_col,
#'     letters = list(
#'       a = a,
#'       b = b
#'     )
#'   )
#' }
#' a_grp <- make_afun(s_grp,
#'   b = 3,
#'   .labels = c(
#'     nrow_df = "row count",
#'     .N_col = "count in column"
#'   ),
#'   .formats = c(nrow_df = "xx.", .N_col = "xx."),
#'   .indent_mods = c(letters = 1L),
#'   .ungroup_stats = "letters"
#' )
#' a_grp(iris, 40)
#' a_aftergrp <- make_afun(a_grp,
#'   .stats = c("nrow_df", "b"),
#'   .formats = c(b = "xx.")
#' )
#' a_aftergrp(iris, 40)
#'
#' s_ref <- function(x, .in_ref_col, .ref_group) {
#'   list(
#'     mean_diff = mean(x) - mean(.ref_group)
#'   )
#' }
#'
#' a_ref <- make_afun(s_ref,
#'   .labels = c(mean_diff = "Mean Difference from Ref")
#' )
#' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)
#' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)
#'
#' @export
make_afun <- function(fun,
                      .stats = NULL,
                      .formats = NULL,
                      .labels = NULL,
                      .indent_mods = NULL,
                      .ungroup_stats = NULL,
                      .format_na_strs = NULL,
                      ...,
                      .null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
  ## there is a LOT more computing-on-the-language hackery in here that I
  ## would prefer, but currently this is the way I see to do everything we
  ## want to do.

  ## too clever by three-quarters (because half wasn't enough)
  ## gross scope hackery
  fun_args <- force(list(...))
  fun_fnames <- names(formals(fun))

  ## force EVERYTHING otherwise calling this within loops is the stuff of
  ## nightmares
  force(.stats)
  force(.formats)
  force(.format_na_strs)
  force(.labels)
  force(.indent_mods)
  force(.ungroup_stats)
  force(.null_ref_cells) ## this one probably isn't needed?

  ret <- function(x, ...) { ## remember formals get clobbered here

    ## this helper will grab the value and wrap it in a named list if
    ## we need the variable and return list() otherwise.
    ## We define it in here so that the scoping hackery works correctly
    .if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
      val <- if (nm %in% fun_fnames) get(nm) else ifnot
      if (named_lwrap && !identical(val, ifnot)) {
        setNames(list(val), nm)
      } else {
        val
      }
    }

    custargs <- fun_args

    ## special handling cause I need it at the bottom as well
    in_rc_argl <- .if_in_formals(".in_ref_col")
    .in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE

    sfunargs <- c(
      ## these are either named lists containing the arg, or list()
      ## depending on whether fun accept the argument or not
      .if_in_formals("x"),
      .if_in_formals("df"),
      .if_in_formals(".N_col"),
      .if_in_formals(".N_total"),
      .if_in_formals(".N_row"),
      .if_in_formals(".ref_group"),
      in_rc_argl,
      .if_in_formals(".df_row"),
      .if_in_formals(".var"),
      .if_in_formals(".ref_full")
    )

    allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
    ## values int he actual call to this function override customization
    ## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE
    if ("..." %in% fun_fnames) {
      exargs <- eval(parser_helper(text = "list(...)"))
      custargs[names(exargs)] <- exargs
      allvars <- unique(c(allvars, names(custargs)))
    }

    for (var in allvars) {
      ## not missing, i.e. specified in the direct call, takes precedence
      if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
        sfunargs[[var]] <- get(var)
      } else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
        sfunargs[[var]] <- custargs[[var]]
      }
      ## else left out so we hit the original default we inherited from fun
    }

    rawvals <- do.call(fun, sfunargs)

    ## note single brackets here so its a list
    ## no matter what. thats important!
    final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]

    if (!is.list(rawvals)) {
      stop("make_afun expects a function fun that always returns a list")
    }
    if (!is.null(.stats)) {
      stopifnot(all(.stats %in% names(rawvals)))
    } else {
      .stats <- names(rawvals)
    }
    if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
      stop(
        "Stats specified for ungrouping not included in non-null .stats list: ",
        setdiff(.ungroup_stats, .stats)
      )
    }

    .labels <- .validate_nms(final_vals, .stats, .labels)
    .formats <- .validate_nms(final_vals, .stats, .formats)
    .indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)
    .format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)

    final_labels <- value_labels(final_vals)
    final_labels[names(.labels)] <- .labels

    final_formats <- lapply(final_vals, obj_format)
    final_formats[names(.formats)] <- .formats

    final_format_na_strs <- lapply(final_vals, obj_na_str)
    final_format_na_strs[names(.format_na_strs)] <- .format_na_strs

    if (is(final_vals, "RowsVerticalSection")) {
      final_imods <- indent_mod(final_vals)
    } else {
      final_imods <- vapply(final_vals, indent_mod, 1L)
    }
    final_imods[names(.indent_mods)] <- .indent_mods

    if (!is.null(.ungroup_stats)) {
      for (nm in .ungroup_stats) {
        tmp <- final_vals[[nm]]
        if (is(tmp, "CellValue")) {
          tmp <- tmp[[1]]
        } ## unwrap it
        final_vals <- insert_replace(final_vals, nm, tmp)
        stopifnot(all(nzchar(names(final_vals))))

        final_labels <- insert_replace(
          final_labels,
          nm,
          setNames(
            value_labels(tmp),
            names(tmp)
          )
        )
        final_formats <- insert_replace(
          final_formats,
          nm,
          setNames(
            rep(final_formats[nm],
              length.out = length(tmp)
            ),
            names(tmp)
          )
        )
        final_format_na_strs <- insert_replace(
          final_format_na_strs,
          nm,
          setNames(
            rep(final_format_na_strs[nm],
              length.out = length(tmp)
            ),
            names(tmp)
          )
        )
        final_imods <- insert_replace(
          final_imods,
          nm,
          setNames(
            rep(final_imods[nm],
              length.out = length(tmp)
            ),
            names(tmp)
          )
        )
      }
    }
    rcells <- mapply(
      function(x, f, l, na_str) {
        if (is(x, "CellValue")) {
          obj_label(x) <- l
          obj_format(x) <- f
          obj_na_str(x) <- na_str
          #                indent_mod(x) <- im
          x
        } else if (.null_ref_cells) {
          non_ref_rcell(x,
            is_ref = .in_ref_col,
            format = f, label = l,
            format_na_str = na_str
          ) # , indent_mod = im)
        } else {
          rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)
        }
      },
      f = final_formats, x = final_vals,
      l = final_labels,
      na_str = final_format_na_strs,
      #        im = final_imods,
      SIMPLIFY = FALSE
    )
    in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)
  }
  formals(ret) <- formals(fun)
  ret
}

insert_replace <- function(x, nm, newvals = x[[nm]]) {
  i <- match(nm, names(x))
  if (is.na(i)) {
    stop("name not found")
  }
  bef <- if (i > 1) 1:(i - 1) else numeric()
  aft <- if (i < length(x)) (i + 1):length(x) else numeric()
  ret <- c(x[bef], newvals, x[aft])
  names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])
  ret
}

parser_helper <- function(text, envir = parent.frame(2)) {
  parse(text = text, keep.source = FALSE)
}

length_w_name <- function(x, .parent_splval) {
  in_rows(length(x),
    .names = value_labels(.parent_splval)
  )
}

#' @import formatters
#' @importMethodsFrom formatters toString matrix_form nlines
NULL

# toString ----

## #' @export
## setGeneric("toString", function(x,...) standardGeneric("toString"))

## ## preserve S3 behavior
## setMethod("toString", "ANY", base::toString)

## #' @export
## setMethod("print", "ANY", base::print)

#' Convert an `rtable` object to a string
#'
#' @inheritParams formatters::toString
#' @inheritParams gen_args
#' @inherit formatters::toString
#'
#' @return A string representation of `x` as it appears when printed.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
#'
#' tbl <- build_table(lyt, iris2)
#'
#' cat(toString(tbl, col_gap = 3))
#'
#' @rdname tostring
#' @aliases tostring toString,VTableTree-method
#' @exportMethod toString
setMethod("toString", "VTableTree", function(x,
                                             widths = NULL,
                                             col_gap = 3,
                                             hsep = horizontal_sep(x),
                                             indent_size = 2,
                                             tf_wrap = FALSE,
                                             max_width = NULL,
                                             fontspec = font_spec(),
                                             ttype_ok = FALSE) {
  toString(
    matrix_form(x,
      indent_rownames = TRUE,
      indent_size = indent_size,
      fontspec = fontspec,
      col_gap = col_gap
    ),
    widths = widths, col_gap = col_gap,
    hsep = hsep,
    tf_wrap = tf_wrap,
    max_width = max_width,
    fontspec = fontspec,
    ttype_ok = ttype_ok
  )
})

#' Table shells
#'
#' A table shell is a rendering of the table which maintains the structure, but does not display the values, rather
#' displaying the formatting instructions for each cell.
#'
#' @inheritParams formatters::toString
#' @inheritParams gen_args
#'
#' @return
#' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console.
#' * `table_shell_str` returns the string representing the table shell.
#'
#' @seealso [value_formats()] for a matrix of formats for each cell in a table.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
#'
#' tbl <- build_table(lyt, iris2)
#' table_shell(tbl)
#'
#' @export
table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),
                        tf_wrap = FALSE, max_width = NULL) {
  cat(table_shell_str(
    tt = tt, widths = widths, col_gap = col_gap, hsep = hsep,
    tf_wrap = tf_wrap, max_width = max_width
  ))
}

## XXX consider moving to formatters, its really just a function
## of the MatrixPrintForm
#' @rdname table_shell
#' @export
table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),
                            tf_wrap = FALSE, max_width = NULL) {
  matform <- matrix_form(tt, indent_rownames = TRUE)
  format_strs <- vapply(
    as.vector(matform$formats),
    function(x) {
      if (inherits(x, "function")) {
        "<fnc>"
      } else if (inherits(x, "character")) {
        x
      } else {
        stop("Don't know how to make a shell with formats of class: ", class(x))
      }
    }, ""
  )

  format_strs_mat <- matrix(format_strs, ncol = ncol(matform$strings))
  format_strs_mat[, 1] <- matform$strings[, 1]
  nlh <- mf_nlheader(matform)
  format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ]

  matform$strings <- format_strs_mat
  if (is.null(widths)) {
    widths <- propose_column_widths(matform)
  }
  toString(matform,
    widths = widths, col_gap = col_gap, hsep = hsep,
    tf_wrap = tf_wrap, max_width = max_width
  )
}

#' Transform an `rtable` to a list of matrices which can be used for outputting
#'
#' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML
#' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form.
#'
#' @inheritParams gen_args
#' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output
#'   has indented row names (strings pre-fixed).
#' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain
#'   newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`.
#' @param fontspec (`font_spec`)\cr The font that should be used by default when
#'   rendering this `MatrixPrintForm` object, or NULL (the default).
#' @param col_gap (`numeric(1)`)]\cr The number of spaces (in the font specified
#'  by `fontspec`) that should be placed between columns when the table
#'  is rendered directly to text (e.g., by `toString` or `export_as_txt`). Defaults
#'  to `3`.
#'
#' @details
#' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell
#' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal
#' function.
#'
#' @return A list with the following elements:
#'   \describe{
#'     \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels,
#'       and cell values of `tt`.}
#'     \item{`spans`}{The column-span information for each print-string in the `strings` matrix.}
#'     \item{`aligns`}{The text alignment for each print-string in the `strings` matrix.}
#'     \item{`display`}{Whether each print-string in the strings matrix should be printed.}
#'     \item{`row_info`}{The `data.frame` generated by `make_row_df`.}
#'   }
#'
#' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"),
#'     afun = list_wrap_x(summary), format = "xx.xx"
#'   )
#'
#' lyt
#'
#' tbl <- build_table(lyt, iris2)
#'
#' matrix_form(tbl)
#'
#' @export
setMethod(
  "matrix_form", "VTableTree",
  function(obj,
           indent_rownames = FALSE,
           expand_newlines = TRUE,
           indent_size = 2,
           fontspec = NULL,
           col_gap = 3L) {
    stopifnot(is(obj, "VTableTree"))
    check_ccount_vis_ok(obj)
    header_content <- .tbl_header_mat(obj) # first col are for row.names

    sr <- make_row_df(obj, fontspec = fontspec)

    body_content_strings <- if (NROW(sr) == 0) {
      character()
    } else {
      cbind(as.character(sr$label), get_formatted_cells(obj))
    }

    formats_strings <- if (NROW(sr) == 0) {
      character()
    } else {
      cbind("", get_formatted_cells(obj, shell = TRUE))
    }

    tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) {
      sp <- row_cspans(rr)
      rep(sp, times = sp)
    })

    ## the 1 is for row labels
    body_spans <- if (nrow(obj) > 0) {
      cbind(1L, do.call(rbind, tsptmp))
    } else {
      matrix(1, nrow = 0, ncol = ncol(obj) + 1)
    }

    body_aligns <- if (NROW(sr) == 0) {
      character()
    } else {
      cbind("left", get_cell_aligns(obj))
    }

    body <- rbind(header_content$body, body_content_strings)

    hdr_fmt_blank <- matrix("",
      nrow = nrow(header_content$body),
      ncol = ncol(header_content$body)
    )
    if (disp_ccounts(obj)) {
      hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj)))
    }

    formats <- rbind(hdr_fmt_blank, formats_strings)

    spans <- rbind(header_content$span, body_spans)
    row.names(spans) <- NULL

    aligns <- rbind(
      matrix(rep("center", length(header_content$body)),
        nrow = nrow(header_content$body)
      ),
      body_aligns
    )

    aligns[, 1] <- "left" # row names and topleft (still needed for topleft)

    nr_header <- nrow(header_content$body)
    if (indent_rownames) {
      body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent),
        incr = indent_size
      )
      # why also formats?
      formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent),
        incr = indent_size
      )
    } else if (NROW(sr) > 0) {
      sr$indent <- rep(0, NROW(sr))
    }

    col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) {
      if (length(x) == 0) {
        ""
      } else {
        paste(vapply(x, format_fnote_ref, ""), collapse = " ")
      }
    }, ""), ncol = ncol(body))
    body_ref_strs <- get_ref_matrix(obj)

    body <- matrix(
      paste0(
        body,
        rbind(
          col_ref_strs,
          body_ref_strs
        )
      ),
      nrow = nrow(body),
      ncol = ncol(body)
    )

    ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here
    pag_titles <- page_titles(obj)

    MatrixPrintForm(
      strings = body,
      spans = spans,
      aligns = aligns,
      formats = formats,
      ## display = display, purely a function of spans, handled in constructor now
      row_info = sr,
      colpaths = make_col_df(obj)[["path"]],
      ## line_grouping handled internally now line_grouping = 1:nrow(body),
      ref_fnotes = ref_fnotes,
      nlines_header = nr_header, ## this is fixed internally
      nrow_header = nr_header,
      expand_newlines = expand_newlines,
      has_rowlabs = TRUE,
      has_topleft = TRUE,
      main_title = main_title(obj),
      subtitles = subtitles(obj),
      page_titles = pag_titles,
      main_footer = main_footer(obj),
      prov_footer = prov_footer(obj),
      table_inset = table_inset(obj),
      header_section_div = header_section_div(obj),
      horizontal_sep = horizontal_sep(obj),
      indent_size = indent_size,
      fontspec = fontspec,
      col_gap = col_gap
    )
  }
)


check_ccount_vis_ok <- function(tt) {
  ctree <- coltree(tt)
  tlkids <- tree_children(ctree)
  lapply(tlkids, ccvis_check_subtree)
  invisible(NULL)
}

ccvis_check_subtree <- function(ctree) {
  kids <- tree_children(ctree)
  if (is.null(kids)) {
    return(invisible(NULL))
  }
  vals <- vapply(kids, disp_ccounts, TRUE)
  if (length(unique(vals)) > 1) {
    unmatch <- which(!duplicated(vals))[1:2]
    stop(
      "Detected different colcount visibility among sibling facets (those ",
      "arising from the same split_cols_by* layout instruction). This is ",
      "not supported.\n",
      "Set count values to NA if you want a blank space to appear as the ",
      "displayed count for particular facets.\n",
      "First disagreement occured at paths:\n",
      .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[1]]]))), "\n",
      .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[2]]])))
    )
  }
  lapply(kids, ccvis_check_subtree)
  invisible(NULL)
}

.resolve_fn_symbol <- function(fn) {
  if (!is(fn, "RefFootnote")) {
    return(NULL)
  }
  ret <- ref_symbol(fn)
  if (is.na(ret)) {
    ret <- as.character(ref_index(fn))
  }
  ret
}

format_fnote_ref <- function(fn) {
  if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
    return("")
  } else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) {
    return(vapply(fn, format_fnote_ref, ""))
  }
  if (is.list(fn)) {
    inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol))
  } else {
    inds <- .resolve_fn_symbol(fn)
  }
  if (length(inds) > 0) {
    paste0(" {", paste(unique(inds), collapse = ", "), "}")
  } else {
    ""
  }
}

format_fnote_note <- function(fn) {
  if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
    return(character())
  }
  if (is.list(fn)) {
    return(unlist(lapply(unlist(fn), format_fnote_note)))
  }

  if (is(fn, "RefFootnote")) {
    paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn))
  } else {
    NULL
  }
}

.fn_ind_extractor <- function(strs) {
  res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs)))
  res[res == "NA"] <- NA_character_
  ## these mixing is allowed now with symbols
  ## if(!(sum(is.na(res)) %in% c(0L, length(res))))
  ##     stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen")
  res
}

get_ref_matrix <- function(tt) {
  if (ncol(tt) == 0 || nrow(tt) == 0) {
    return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L))
  }
  rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)
  lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE)
  cstrs <- unlist(lapply(lst, format_fnote_ref))
  bodymat <- matrix(cstrs,
    byrow = TRUE,
    nrow = nrow(tt),
    ncol = ncol(tt)
  )
  cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat)
}

get_formatted_fnotes <- function(tt) {
  colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes)
  rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)
  lst <- c(
    colresfs,
    unlist(
      lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)),
      recursive = FALSE
    )
  )

  inds <- vapply(lst, ref_index, 1L)
  ord <- order(inds)
  lst <- lst[ord]
  syms <- vapply(lst, ref_symbol, "")
  keep <- is.na(syms) | !duplicated(syms)
  lst <- lst[keep]
  unique(vapply(lst, format_fnote_note, ""))

  ##                    , recursive = FALSE)
  ## rlst <- unlist(lapply(rows, row_footnotes))
  ## lst <-
  ## syms <- vapply(lst, ref_symbol, "")
  ## keep <- is.na(syms) | !duplicated(syms)
  ## lst <- lst[keep]
  ## inds <- vapply(lst, ref_index, 1L)
  ## cellstrs <- unlist(lapply(lst, format_fnote_note))
  ## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw))))
  ## allstrs <- c(colstrs, rstrs, cellstrs)
  ## inds <- .fn_ind_extractor(allstrs)
  ## allstrs[order(inds)]
}

.do_tbl_h_piece2 <- function(tt) {
  coldf <- make_col_df(tt, visible_only = FALSE)
  remain <- seq_len(nrow(coldf))
  chunks <- list()
  cur <- 1
  na_str <- colcount_na_str(tt)

  ## XXX this would be better as the facet-associated
  ## format but I don't know that we need to
  ## support that level of differentiation anyway...
  cc_format <- colcount_format(tt)
  ## each iteration of this loop identifies
  ## all rows corresponding to one top-level column
  ## label and its children, then processes those
  ## with .do_header_chunk
  while (length(remain) > 0) {
    rw <- remain[1]
    inds <- coldf$leaf_indices[[rw]]
    endblock <- which(coldf$abs_pos == max(inds))

    stopifnot(endblock >= rw)
    chunk_res <- .do_header_chunk(coldf[rw:endblock, ], cc_format, na_str = na_str)
    chunk_res <- unlist(chunk_res, recursive = FALSE)
    chunks[[cur]] <- chunk_res
    remain <- remain[remain > endblock]
    cur <- cur + 1
  }
  chunks <- .pad_tops(chunks)
  lapply(
    seq_len(length(chunks[[1]])),
    function(i) {
      DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE))
    }
  )
}

.pad_end <- function(lst, padto, ncols) {
  curcov <- sum(vapply(lst, cell_cspan, 0L))
  if (curcov == padto) {
    return(lst)
  }

  c(lst, list(rcell("", colspan = padto - curcov)))
}

.pad_tops <- function(chunks) {
  lens <- vapply(chunks, length, 1L)
  padto <- max(lens)
  needpad <- lens != padto
  if (all(!needpad)) {
    return(chunks)
  }

  for (i in seq_along(lens)) {
    if (lens[i] < padto) {
      chk <- chunks[[i]]
      span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L))
      chunks[[i]] <- c(
        replicate(list(list(rcell("", colspan = span))),
          n = padto - lens[i]
        ),
        chk
      )
    }
  }
  chunks
}

.do_header_chunk <- function(coldf, cc_format, na_str) {
  ## hard assumption that coldf is a section
  ## of a column dataframe summary that was
  ## created with visible_only=FALSE
  nleafcols <- length(coldf$leaf_indices[[1]])

  spldfs <- split(coldf, lengths(coldf$path))
  toret <- lapply(
    seq_along(spldfs),
    function(i) {
      rws <- spldfs[[i]]
      thisbit_vals <- lapply(
        seq_len(nrow(rws)),
        function(ri) {
          cellii <- rcell(rws[ri, "label", drop = TRUE],
            colspan = rws$total_span[ri],
            footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]]
          )
          cellii
        }
      )
      ret <- list(.pad_end(thisbit_vals, padto = nleafcols))
      anycounts <- any(rws$ccount_visible)
      if (anycounts) {
        thisbit_ns <- lapply(
          seq_len(nrow(rws)),
          function(ri) {
            vis_ri <- rws$ccount_visible[ri]
            val <- if (vis_ri) rws$col_count[ri] else NULL
            fmt <- rws$ccount_format[ri]
            if (is.character(fmt)) {
              cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == fmt))))
              if (cfmt_dim == "2d") {
                if (grepl("%", fmt)) {
                  val <- c(val, 1) ## XXX This is the old behavior but it doesn't take into account parent counts...
                } else {
                  stop(
                    "This 2d format is not supported for column counts. ",
                    "Please choose a 1d format or a 2d format that includes a % value."
                  )
                }
              } else if (cfmt_dim == "3d") {
                stop("3d formats are not supported for column counts.")
              }
            }
            cellii <- rcell(
              val,
              colspan = rws$total_span[ri],
              format = fmt, # cc_format,
              format_na_str = na_str
            )
            cellii
          }
        )
        ret <- c(ret, list(.pad_end(thisbit_ns, padto = nleafcols)))
      }
      ret
    }
  )
  toret
}

.tbl_header_mat <- function(tt) {
  rows <- .do_tbl_h_piece2(tt) ## (clyt)
  cinfo <- col_info(tt)

  nc <- ncol(tt)
  body <- matrix(rapply(rows, function(x) {
    cs <- row_cspans(x)
    strs <- get_formatted_cells(x)
    strs
  }), ncol = nc, byrow = TRUE)

  span <- matrix(rapply(rows, function(x) {
    cs <- row_cspans(x)
    if (is.null(cs)) cs <- rep(1, ncol(x))
    rep(cs, cs)
  }), ncol = nc, byrow = TRUE)

  fnote <- do.call(
    rbind,
    lapply(rows, function(x) {
      cell_footnotes(x)
    })
  )

  tl <- top_left(cinfo)
  lentl <- length(tl)
  nli <- nrow(body)
  if (lentl == 0) {
    tl <- rep("", nli)
  } else if (lentl > nli) {
    tl_tmp <- paste0(tl, collapse = "\n")
    tl <- rep("", nli)
    tl[length(tl)] <- tl_tmp
  } else if (lentl < nli) {
    # We want topleft alignment that goes to the bottom!
    tl <- c(rep("", nli - lentl), tl)
  }
  list(
    body = cbind(tl, body, deparse.level = 0), span = cbind(1, span),
    footnotes = cbind(list(list()), fnote)
  )
}

# get formatted cells ----

#' Get formatted cells
#'
#' @inheritParams gen_args
#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats
#'   applied. Defaults to `FALSE`.
#'
#' @return The formatted print-strings for all (body) cells in `obj`.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' tbl <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>%
#'   build_table(iris2)
#'
#' get_formatted_cells(tbl)
#'
#' @export
#' @rdname gfc
setGeneric("get_formatted_cells", function(obj, shell = FALSE) standardGeneric("get_formatted_cells"))

#' @rdname gfc
setMethod(
  "get_formatted_cells", "TableTree",
  function(obj, shell = FALSE) {
    lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)

    ct <- get_formatted_cells(content_table(obj), shell = shell)

    els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)

    ## TODO fix ncol problem for rrow()
    if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
      ct <- lr[NULL, ]
    }

    do.call(rbind, c(list(lr), list(ct), els))
  }
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "ElementaryTable",
  function(obj, shell = FALSE) {
    lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)
    els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)
    do.call(rbind, c(list(lr), els))
  }
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "TableRow",
  function(obj, shell = FALSE) {
    # Parent row format and na_str
    pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj)
    pr_row_na_str <- obj_na_str(obj) %||% "NA"

    matrix(
      unlist(Map(function(val, spn, shelli) {
        stopifnot(is(spn, "integer"))

        out <- format_rcell(val,
          pr_row_format = pr_row_format,
          pr_row_na_str = pr_row_na_str,
          shell = shelli
        )
        if (!is.function(out) && is.character(out)) {
          out <- paste(out, collapse = ", ")
        }

        rep(list(out), spn)
      }, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)),
      ncol = ncol(obj)
    )
  }
)

#' @rdname gfc
setMethod(
  "get_formatted_cells", "LabelRow",
  function(obj, shell = FALSE) {
    nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
    vstr <- if (shell) "-" else ""
    if (labelrow_visible(obj)) {
      matrix(rep(vstr, nc), ncol = nc)
    } else {
      matrix(character(0), ncol = nc)
    }
  }
)

#' @rdname gfc
setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns"))

#' @rdname gfc
setMethod(
  "get_cell_aligns", "TableTree",
  function(obj) {
    lr <- get_cell_aligns(tt_labelrow(obj))

    ct <- get_cell_aligns(content_table(obj))

    els <- lapply(tree_children(obj), get_cell_aligns)

    ## TODO fix ncol problem for rrow()
    if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
      ct <- lr[NULL, ]
    }

    do.call(rbind, c(list(lr), list(ct), els))
  }
)

#' @rdname gfc
setMethod(
  "get_cell_aligns", "ElementaryTable",
  function(obj) {
    lr <- get_cell_aligns(tt_labelrow(obj))
    els <- lapply(tree_children(obj), get_cell_aligns)
    do.call(rbind, c(list(lr), els))
  }
)

#' @rdname gfc
setMethod(
  "get_cell_aligns", "TableRow",
  function(obj) {
    als <- vapply(row_cells(obj), cell_align, "")
    spns <- row_cspans(obj)

    matrix(rep(als, times = spns),
      ncol = ncol(obj)
    )
  }
)

#' @rdname gfc
setMethod(
  "get_cell_aligns", "LabelRow",
  function(obj) {
    nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
    if (labelrow_visible(obj)) {
      matrix(rep("center", nc), ncol = nc)
    } else {
      matrix(character(0), ncol = nc)
    }
  }
)

# utility functions ----

#' From a sorted sequence of numbers, remove numbers where diff == 1
#'
#' @examples
#' remove_consecutive_numbers(x = c(2, 4, 9))
#' remove_consecutive_numbers(x = c(2, 4, 5, 9))
#' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9))
#' remove_consecutive_numbers(x = 4:9)
#'
#' @noRd
remove_consecutive_numbers <- function(x) {
  # actually should be integer
  stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x))

  if (length(x) == 0) {
    return(integer(0))
  }
  if (!is.integer(x)) x <- as.integer(x)

  x[c(TRUE, diff(x) != 1)]
}

#' Insert an empty string
#'
#' @examples
#' empty_string_after(letters[1:5], 2)
#' empty_string_after(letters[1:5], c(2, 4))
#'
#' @noRd
empty_string_after <- function(x, indices) {
  if (length(indices) > 0) {
    offset <- 0
    for (i in sort(indices)) {
      x <- append(x, "", i + offset)
      offset <- offset + 1
    }
  }
  x
}

#' Indent strings
#'
#' Used in rtables to indent row names for the ASCII output.
#'
#' @param x (`character`)\cr a character vector.
#' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`.
#' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level.
#' @param including_newline (`flag`)\cr whether newlines should also be indented.
#'
#' @return `x`, indented with left-padding with `indent * incr` white-spaces.
#'
#' @examples
#' indent_string("a", 0)
#' indent_string("a", 1)
#' indent_string(letters[1:3], 0:2)
#' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2)
#'
#' @export
indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) {
  if (length(x) > 0) {
    indent <- rep_len(indent, length.out = length(x))
    incr <- rep_len(incr, length.out = length(x))
  }

  indent_str <- strrep(" ", (indent > 0) * indent * incr)

  if (including_newline) {
    x <- unlist(mapply(function(xi, stri) {
      gsub("\n", stri, xi, fixed = TRUE)
    }, x, paste0("\n", indent_str)))
  }

  paste0(indent_str, x)
}

## .paste_no_na <- function(x, ...) {
##   paste(na.omit(x), ...)
## }

## #' Pad a string and align within string
## #'
## #' @param x string
## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown
## #'
## #' @noRd
## #'
## #' @examples
## #'
## #' padstr("abc", 3)
## #' padstr("abc", 4)
## #' padstr("abc", 5)
## #' padstr("abc", 5, "left")
## #' padstr("abc", 5, "right")
## #'
## #' if(interactive()){
## #' padstr("abc", 1)
## #' }
## #'
## padstr <- function(x, n, just = c("center", "left", "right")) {

##   just <- match.arg(just)

##   if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
##   if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")

##   if (is.na(x)) x <- "<NA>"

##   nc <- nchar(x)

##   if (n < nc) stop("\"", x, "\" has more than ", n, " characters")

##   switch(
##     just,
##     center = {
##       pad <- (n - nc)/2
##       paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
##     },
##     left = paste0(x, spaces(n - nc)),
##     right = paste0(spaces(n - nc), x)
##   )
## }

## spaces <- function(n) {
##   strrep(" ", n)
## }

#' Convert matrix of strings into a string with aligned columns
#'
#' Note that this function is intended to print simple rectangular matrices and not `rtable`s.
#'
#' @param mat (`matrix`)\cr a matrix of strings.
#' @param nheader (`integer(1)`)\cr number of header rows.
#' @param colsep (`string`)\cr a string that separates the columns.
#' @param hsep (`character(1)`)\cr character to build line separator.
#'
#' @return A string.
#'
#' @examples
#' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE)
#' cat(mat_as_string(mat))
#' cat("\n")
#'
#' @noRd
mat_as_string <- function(mat, nheader = 1, colsep = "    ", hsep = default_hsep()) {
  colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max)

  rows_formatted <- apply(mat, 1, function(row) {
    paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep)
  })

  header_rows <- seq_len(nheader)
  nchwidth <- nchar(rows_formatted[1])
  paste(c(
    rows_formatted[header_rows],
    substr(strrep(hsep, nchwidth), 1, nchwidth),
    rows_formatted[-header_rows]
  ), collapse = "\n")
}

# Split functions --------------------------------------------------------------
#' Split functions
#'
#' @description
#' This is a collection of useful, default split function that can help you in dividing the data, hence the
#' table rows or columns, into different parts or groups (splits). You can also create your own split function if you
#' need to create a custom division as specific as you need. Please consider reading [custom_split_funs] if
#' this is the case. Beyond this list of functions, you can also use [add_overall_level()] and [add_combo_levels()]
#' for adding or modifying levels and [trim_levels_to_map()] to provide possible level combinations to filter the split
#' with.
#'
#' @inheritParams sf_args
#' @inheritParams gen_args
#' @param vals (`ANY`)\cr for internal use only.
#' @param labels (`character`)\cr labels to use for the remaining levels instead of the existing ones.
#'
#' @returns A function that can be used to split the data accordingly. The actual function signature
#'   is similar to the one you can define when creating a fully custom one. For more details see [custom_split_funs].
#'
#' @note
#' The following parameters are also documented here but they are only the default
#' signature of a split function: `df` (data to be split), `spl` (split object), and `vals = NULL`,
#' `labels = NULL`, `trim = FALSE` (last three only for internal use). See [custom_split_funs] for more details
#' and [make_split_fun()] for a more advanced API.
#'
#' @seealso [custom_split_funs], [add_overall_level()], [add_combo_levels()], and [trim_levels_to_map()].
#'
#' @name split_funcs
NULL

# helper fncs
.get_unique_levels <- function(vec) {
  out <- if (is.factor(vec)) {
    levels(vec)
  } else {
    unique(vec)
  }

  out
}

.print_setdiff_error <- function(provided, existing) {
  paste(setdiff(provided, existing), collapse = ", ")
}

#' @describeIn split_funcs keeps only specified levels (`only`) in the split variable. If any of the specified
#'   levels is not present, an error is returned. `reorder = TRUE` (the default) orders the split levels
#'   according to the order of `only`.
#'
#' @param only (`character`)\cr levels to retain (all others will be dropped). If none of the levels is present
#'   an empty table is returned.
#' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the
#'   split. Defaults to `TRUE`.
#'
#' @examples
#' # keep_split_levels keeps specified levels (reorder = TRUE by default)
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY",
#'     split_fun = keep_split_levels(c("USA", "CAN", "BRA"))
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
keep_split_levels <- function(only, reorder = TRUE) {
  function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    var <- spl_payload(spl)
    varvec <- df[[var]]

    # Unique values from the split variable
    unique_vals <- .get_unique_levels(varvec)

    # Error in case not all levels are present
    if (!all(only %in% unique_vals)) {
      stop(
        "Attempted to keep factor level(s) in split that are not present in data: \n",
        .print_setdiff_error(only, unique_vals)
      )
    }

    df2 <- df[varvec %in% only, ]
    if (reorder) {
      df2[[var]] <- factor(df2[[var]], levels = only)
    } else {
      # Find original order of only
      only <- unique_vals[sort(match(only, unique_vals))]
    }

    spl_child_order(spl) <- only
    .apply_split_inner(spl, df2,
      vals = only,
      labels = labels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Removes specified levels (`excl`) from the split variable. Nothing done if not in data.
#'
#' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure
#'   regardless of presence in the data).
#'
#' @examples
#' # remove_split_levels removes specified split levels
#' lyt <- basic_table() %>%
#'   split_rows_by("COUNTRY",
#'     split_fun = remove_split_levels(c(
#'       "USA", "CAN",
#'       "CHE", "BRA"
#'     ))
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
remove_split_levels <- function(excl) {
  stopifnot(is.character(excl))
  function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    var <- spl_payload(spl)
    df2 <- df[!(df[[var]] %in% excl), ]
    if (is.factor(df2[[var]])) {
      levels <- levels(df2[[var]])
      levels <- levels[!(levels %in% excl)]
      df2[[var]] <- factor(df2[[var]], levels = levels)
    }
    .apply_split_inner(spl, df2,
      vals = vals,
      labels = labels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Drops levels that have no representation in the data.
#'
#' @examples
#' # drop_split_levels drops levels that are not present in the data
#' lyt <- basic_table() %>%
#'   split_rows_by("SEX", split_fun = drop_split_levels) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
drop_split_levels <- function(df,
                              spl,
                              vals = NULL,
                              labels = NULL,
                              trim = FALSE) {
  var <- spl_payload(spl)
  df2 <- df
  df2[[var]] <- factor(df[[var]])
  lblvar <- spl_label_var(spl)
  if (!is.null(lblvar)) {
    df2[[lblvar]] <- factor(df[[lblvar]])
  }

  .apply_split_inner(spl, df2,
    vals = vals,
    labels = labels,
    trim = trim
  )
}

#' @describeIn split_funcs Removes specified levels `excl` and drops all levels that are
#'   not in the data.
#'
#' @examples
#' # Removing "M" and "U" directly, then "UNDIFFERENTIATED" because not in data
#' lyt <- basic_table() %>%
#'   split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
drop_and_remove_levels <- function(excl) {
  stopifnot(is.character(excl))
  function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    var <- spl_payload(spl)
    df2 <- df[!(df[[var]] %in% excl), ]
    df2[[var]] <- factor(df2[[var]])
    .apply_split_inner(
      spl,
      df2,
      vals = vals,
      labels = labels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Reorders split levels following `neworder`, which needs to be of
#'   same size as the levels in data.
#'
#' @param neworder (`character`)\cr new order of factor levels. All need to be present in the data.
#'   To add empty levels, rely on pre-processing or create your [custom_split_funs].
#' @param newlabels (`character`)\cr labels for (new order of) factor levels. If named, the levels are matched.
#'   Otherwise, the order of `neworder` is used.
#' @param drlevels (`flag`)\cr whether levels that are not in `neworder` should be dropped.
#'   Default is `TRUE`. Note: `drlevels = TRUE` does not drop levels that are not originally in the data.
#'   Rely on pre-processing or use a combination of split functions with [make_split_fun()] to also drop
#'   unused levels.
#'
#' @examples
#' # Reordering levels in split variable
#' lyt <- basic_table() %>%
#'   split_rows_by(
#'     "SEX",
#'     split_fun = reorder_split_levels(
#'       neworder = c("U", "F"),
#'       newlabels = c(U = "Uu", `F` = "Female")
#'     )
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' # Reordering levels in split variable but keeping all the levels
#' lyt <- basic_table() %>%
#'   split_rows_by(
#'     "SEX",
#'     split_fun = reorder_split_levels(
#'       neworder = c("U", "F"),
#'       newlabels = c("Uu", "Female"),
#'       drlevels = FALSE
#'     )
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' @export
reorder_split_levels <- function(neworder,
                                 newlabels = neworder,
                                 drlevels = TRUE) {
  function(df, spl, trim, ...) {
    df2 <- df
    valvec <- df2[[spl_payload(spl)]]

    uni_vals <- .get_unique_levels(valvec)

    # No sense adding things that are not present -> creating unexpected NAs
    if (!all(neworder %in% uni_vals)) {
      stop(
        "Attempted to reorder factor levels in split that are not present in data:\n",
        .print_setdiff_error(neworder, uni_vals)
      )
    }

    # Keeping all levels also from before if not dropped
    diff_with_uni_vals <- setdiff(uni_vals, neworder)
    if (!drlevels && length(diff_with_uni_vals) > 0) {
      if (length(newlabels) > length(neworder)) {
        stop(
          "When keeping levels not in neworder (drlevels = FALSE), newlabels can ",
          "affect only selected neworder, and not other levels.\n",
          "Add labels for current neworder: ", paste0(neworder, collapse = ", ")
        )
      }
      neworder <- c(neworder, diff_with_uni_vals)
      if (is.null(names(newlabels))) {
        newlabels <- c(newlabels, diff_with_uni_vals)
      } else {
        newlabels <- c(newlabels, setNames(diff_with_uni_vals, diff_with_uni_vals))
      }
    }

    valvec <- factor(valvec, levels = neworder)

    # Labels
    if (!is.null(names(newlabels))) {
      if (any(!names(newlabels) %in% neworder)) {
        stop(
          "Got labels' names for levels that are not present:\n",
          setdiff(names(newlabels), neworder)
        )
      }
      # To be safe: sorting by neworder
      newlabels <- newlabels[sapply(names(newlabels), function(x) which(x == neworder))]
    } else if (length(neworder) != length(newlabels)) {
      stop(
        "Got unnamed newlabels with different length than neworder. ",
        "Please provide names or make sure they are of the same length.\n",
        "Current neworder: ", paste0(neworder, collapse = ", ")
      )
    }

    # Final values
    spl_child_order(spl) <- neworder
    df2[[spl_payload(spl)]] <- valvec
    .apply_split_inner(spl, df2,
      vals = neworder,
      labels = newlabels,
      trim = trim
    )
  }
}

#' @describeIn split_funcs Takes the split groups and removes levels of `innervar` if not present in
#'   those split groups. If you want to specify a filter of possible combinations, please
#'   consider using [trim_levels_to_map()].
#'
#' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped)
#'   *separately within each grouping defined at this point in the structure*.
#' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer"
#'   variable, not `innervar`) should be dropped. Defaults to `TRUE`.
#'
#' @examples
#' # trim_levels_in_group() trims levels within each group defined by the split variable
#' dat <- data.frame(
#'   col1 = factor(c("A", "B", "C"), levels = c("A", "B", "C", "N")),
#'   col2 = factor(c("a", "b", "c"), levels = c("a", "b", "c", "x"))
#' ) # N is removed if drop_outlevs = TRUE, x is removed always
#'
#' tbl <- basic_table() %>%
#'   split_rows_by("col1", split_fun = trim_levels_in_group("col2")) %>%
#'   analyze("col2") %>%
#'   build_table(dat)
#' tbl
#'
#' @export
trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) {
  myfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
    if (!drop_outlevs) {
      ret <- .apply_split_inner(spl, df,
        vals = vals,
        labels = labels, trim = trim
      )
    } else {
      ret <- drop_split_levels(
        df = df, spl = spl, vals = vals,
        labels = labels, trim = trim
      )
    }

    ret$datasplit <- lapply(ret$datasplit, function(x) {
      coldat <- x[[innervar]]
      if (is(coldat, "character")) {
        if (!is.null(vals)) {
          lvs <- vals
        } else {
          lvs <- unique(coldat)
        }
        coldat <- factor(coldat, levels = lvs) ## otherwise
      } else {
        coldat <- droplevels(coldat)
      }
      x[[innervar]] <- coldat
      x
    })
    ret$labels <- as.character(ret$labels) # TODO
    ret
  }
  myfun
}

# add_combo_levels -------------------------------------------------------------
# Dedicated docs are attached to default split functions
.add_combo_part_info <- function(part,
                                 df,
                                 valuename,
                                 levels,
                                 label,
                                 extras,
                                 first = TRUE) {
  value <- LevelComboSplitValue(valuename, extras,
    combolevels = levels,
    label = label
  )
  newdat <- setNames(list(df), valuename)
  newval <- setNames(list(value), valuename)
  newextra <- setNames(list(extras), valuename)
  if (first) {
    part$datasplit <- c(newdat, part$datasplit)
    part$values <- c(newval, part$values)
    part$labels <- c(setNames(label, valuename), part$labels)
    part$extras <- c(newextra, part$extras)
  } else {
    part$datasplit <- c(part$datasplit, newdat)
    part$values <- c(part$values, newval)
    part$labels <- c(part$labels, setNames(label, valuename))
    part$extras <- c(part$extras, newextra)
  }
  ## not needed even in custom split function case.
  ##   part = .fixupvals(part)
  part
}

#' Add overall or combination levels to split groups
#'
#' @description
#' `add_overall_level` is a split function that adds a global level to the current levels in the split. Similarly,
#' `add_combo_df` uses a user-provided `data.frame` to define the combine the levels to be added. If you need a
#' single overall column, after all splits, please check [add_overall_col()]. Consider also defining
#' your custom split function if you need more flexibility (see [custom_split_funs]).
#'
#' @inheritParams lyt_args
#' @inheritParams sf_args
#' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to
#'   `"Overall"`.
#' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults
#'   to `TRUE`.
#'
#' @return A splitting function (`splfun`) that adds or changes the levels of a split.
#'
#' @seealso [custom_split_funs] and [split_funcs].
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM", split_fun = add_overall_level("All Patients",
#'     first = FALSE
#'   )) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE",
#'     split_fun = add_overall_level("All Ethnicities")
#'   ) %>%
#'   summarize_row_groups(label_fstr = "%s (n)") %>%
#'   analyze("AGE")
#' lyt2
#'
#' tbl2 <- build_table(lyt2, DM)
#' tbl2
#'
#' @export
add_overall_level <- function(valname = "Overall",
                              label = valname,
                              extra_args = list(),
                              first = TRUE,
                              trim = FALSE) {
  combodf <- data.frame(
    valname = valname,
    label = label,
    levelcombo = I(list(select_all_levels)),
    exargs = I(list(extra_args)),
    stringsAsFactors = FALSE
  )
  add_combo_levels(combodf,
    trim = trim, first = first
  )
}

setClass("AllLevelsSentinel", contains = "character")

# nocov start
#' @rdname add_overall_level
#' @export
select_all_levels <- new("AllLevelsSentinel")
# nocov end

#' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and
#'   `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in
#'   `comblevels` column indicates that an overall/all-observations level should be created.
#' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and
#'   individual levels.
#'
#' @inherit add_overall_level return
#'
#' @note
#' Analysis or summary functions for which the order matters should never be used within the tabulation framework.
#'
#' @examplesIf require(tibble)
#'
#' library(tibble)
#' combodf <- tribble(
#'   ~valname, ~label, ~levelcombo, ~exargs,
#'   "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(),
#'   "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list()
#' )
#'
#' lyt <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#' tbl
#'
#' lyt1 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM",
#'     split_fun = add_combo_levels(combodf,
#'       keep_levels = c(
#'         "A_B",
#'         "A_C"
#'       )
#'     )
#'   ) %>%
#'   analyze("AGE")
#'
#' tbl1 <- build_table(lyt1, DM)
#' tbl1
#'
#' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") &
#'   grepl("^(A|B)", ARM)))
#' lyt2 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>%
#'   split_cols_by("SEX",
#'     split_fun = add_overall_level("SEX_ALL", "All Genders")
#'   ) %>%
#'   analyze("AGE")
#'
#' lyt3 <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
#'   split_rows_by("SEX",
#'     split_fun = add_overall_level("SEX_ALL", "All Genders")
#'   ) %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE")
#'
#' tbl3 <- build_table(lyt3, smallerDM)
#' tbl3
#'
#' @rdname add_overall_level
#' @export
add_combo_levels <- function(combosdf,
                             trim = FALSE,
                             first = FALSE,
                             keep_levels = NULL) {
  myfun <- function(df, spl, vals = NULL, labels = NULL, ...) {
    if (is(spl, "MultiVarSplit")) {
      stop("Combining levels of a MultiVarSplit does not make sense.",
        call. = FALSE
      )
    } # nocov
    ret <- .apply_split_inner(spl, df,
      vals = vals,
      labels = labels, trim = trim
    )
    for (i in seq_len(nrow(combosdf))) {
      lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]]
      spld <- spl_payload(spl)
      if (is(lcombo, "AllLevelsSentinel")) {
        subdf <- df
      } else if (is(spl, "VarLevelSplit")) {
        subdf <- df[df[[spld]] %in% lcombo, ]
      } else { ## this covers non-var splits, e.g. Cut-based splits
        stopifnot(all(lcombo %in% c(ret$labels, ret$vals)))
        subdf <- do.call(
          rbind,
          ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo]
        )
      }
      ret <- .add_combo_part_info(
        ret, subdf,
        combosdf[i, "valname", drop = TRUE],
        lcombo,
        combosdf[i, "label", drop = TRUE],
        combosdf[i, "exargs", drop = TRUE][[1]],
        first
      )
    }
    if (!is.null(keep_levels)) {
      keep_inds <- value_names(ret$values) %in% keep_levels
      ret <- lapply(ret, function(x) x[keep_inds])
    }

    ret
  }
  myfun
}

#' Trim levels to map
#'
#' This split function constructor creates a split function which trims levels of a variable to reflect restrictions
#' on the possible combinations of two or more variables which the data is split by (along the same axis) within a
#' layout.
#'
#' @param map data.frame. A data.frame defining allowed combinations of
#'   variables. Any combination at the level of this split not present in the
#'   map will be removed from the data, both for the variable being split and
#'   those present in the data but not associated with this split or any parents
#'   of it.
#'
#' @details
#' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the
#' variable being split are then pruned to only those still present within this subset of the map representing the
#' current hierarchical splitting context.
#'
#' Splitting is then performed via the [keep_split_levels()] split function.
#'
#' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables
#' specified in the map to those values allowed under the combination of the previous and current split.
#'
#' @return A function that can be used as a split function.
#'
#' @seealso [trim_levels_in_group()].
#'
#' @examples
#' map <- data.frame(
#'   LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
#'   PARAMCD = c("ALT", "CRP", "CRP", "IGA"),
#'   ANRIND = c("LOW", "LOW", "HIGH", "HIGH"),
#'   stringsAsFactors = FALSE
#' )
#'
#' lyt <- basic_table() %>%
#'   split_rows_by("LBCAT") %>%
#'   split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>%
#'   analyze("ANRIND")
#' tbl <- build_table(lyt, ex_adlb)
#'
#' @export
trim_levels_to_map <- function(map = NULL) {
  if (is.null(map) || any(sapply(map, class) != "character")) {
    stop(
      "No map dataframe was provided or not all of the columns are of ",
      "type character."
    )
  }

  myfun <- function(df,
                    spl,
                    vals = NULL,
                    labels = NULL,
                    trim = FALSE,
                    .spl_context) {
    allvars <- colnames(map)
    splvar <- spl_payload(spl)

    allvmatches <- match(.spl_context$split, allvars)
    outvars <- allvars[na.omit(allvmatches)]
    ## invars are variables present in data, but not in
    ## previous or current splits
    invars <- intersect(
      setdiff(allvars, c(outvars, splvar)),
      names(df)
    )
    ## allvarord <- c(na.omit(allvmatches), ## appear in prior splits
    ##                which(allvars == splvar), ## this split
    ##                allvars[-1*na.omit(allvmatches)]) ## "outvars"

    ## allvars <- allvars[allvarord]
    ## outvars <- allvars[-(which(allvars == splvar):length(allvars))]
    if (length(outvars) > 0) {
      indfilters <- vapply(outvars, function(ivar) {
        obsval <- .spl_context$value[match(ivar, .spl_context$split)]
        sprintf("%s == '%s'", ivar, obsval)
      }, "")

      allfilters <- paste(indfilters, collapse = " & ")
      map <- map[eval(parse(text = allfilters), envir = map), ]
    }
    map_splvarpos <- which(names(map) == splvar)
    nondup <- !duplicated(map[[splvar]])
    ksl_fun <- keep_split_levels(
      only = map[[splvar]][nondup],
      reorder = TRUE
    )
    ret <- ksl_fun(df, spl, vals, labels, trim = trim)

    if (length(ret$datasplit) == 0) {
      msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value),
        collapse = "->"
      )
      stop(
        "map does not allow any values present in data for split ",
        "variable ", splvar,
        " under the following parent splits:\n\t", msg
      )
    }

    ## keep non-split (inner) variables levels
    ret$datasplit <- lapply(ret$values, function(splvar_lev) {
      df3 <- ret$datasplit[[splvar_lev]]
      curmap <- map[map[[map_splvarpos]] == splvar_lev, ]
      ## loop through inner variables
      for (iv in invars) { ## setdiff(colnames(map), splvar)) {
        iv_lev <- df3[[iv]]
        levkeep <- as.character(unique(curmap[[iv]]))
        if (is.factor(iv_lev) && !all(levkeep %in% levels(iv_lev))) {
          stop(
            "Attempted to keep invalid factor level(s) in split ",
            setdiff(levkeep, levels(iv_lev))
          )
        }

        df3 <- df3[iv_lev %in% levkeep, , drop = FALSE]

        if (is.factor(iv_lev)) {
          df3[[iv]] <- factor(as.character(df3[[iv]]),
            levels = levkeep
          )
        }
      }

      df3
    })
    names(ret$datasplit) <- ret$values
    ret
  }

  myfun
}

# paths summary ----

#' Get a list of table row/column paths
#'
#' @param x (`VTableTree`)\cr an `rtable` object.
#'
#' @return A list of paths to each row/column within `x`.
#'
#' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("SEX", "AGE"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' tbl
#'
#' row_paths(tbl)
#' col_paths(tbl)
#'
#' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
#'
#' @rdname make_col_row_df
#' @export
row_paths <- function(x) {
  stopifnot(is_rtable(x))
  make_row_df(x, visible_only = TRUE)$path
}

#' @rdname make_col_row_df
#' @export
col_paths <- function(x) {
  if (!is(coltree(x), "LayoutColTree")) {
    stop("I don't know how to extract the column paths from an object of class ", class(x))
  }
  make_col_df(x, visible_only = TRUE)$path
}

#' Print row/column paths summary
#'
#' @param x (`VTableTree`)\cr an `rtable` object.
#'
#' @return A data frame summarizing the row- or column-structure of `x`.
#'
#' @examplesIf require(dplyr)
#' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("SEX", split_fun = drop_split_levels) %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl_MF)
#' tbl
#'
#' df <- row_paths_summary(tbl)
#' df
#'
#' col_paths_summary(tbl)
#'
#' # manually constructed table
#' tbl2 <- rtable(
#'   rheader(
#'     rrow(
#'       "row 1", rcell("a", colspan = 2),
#'       rcell("b", colspan = 2)
#'     ),
#'     rrow("h2", "a", "b", "c", "d")
#'   ),
#'   rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
#' )
#' col_paths_summary(tbl2)
#'
#' @export
row_paths_summary <- function(x) {
  stopifnot(is_rtable(x))

  if (nrow(x) == 0) {
    return("rowname     node_class       path\n---------------------\n")
  }

  pagdf <- make_row_df(x, visible_only = TRUE)
  row.names(pagdf) <- NULL

  mat <- rbind(
    c("rowname", "node_class", "path"),
    t(apply(pagdf, 1, function(xi) {
      c(
        indent_string(xi$label, xi$indent),
        xi$node_class,
        paste(xi$path, collapse = ", ")
      )
    }))
  )

  txt <- mat_as_string(mat)
  cat(txt)
  cat("\n")

  invisible(pagdf[, c("label", "indent", "node_class", "path")])
}

#' @rdname row_paths_summary
#' @export
col_paths_summary <- function(x) {
  stopifnot(is_rtable(x))

  pagdf <- make_col_df(x, visible_only = FALSE)
  row.names(pagdf) <- NULL

  mat <- rbind(
    c("label", "path"),
    t(apply(pagdf, 1, function(xi) {
      c(
        indent_string(xi$label, floor(length(xi$path) / 2 - 1)),
        paste(xi$path, collapse = ", ")
      )
    }))
  )

  txt <- mat_as_string(mat)
  cat(txt)
  cat("\n")

  invisible(pagdf[, c("label", "path")])
}

# Rows ----
# . Summarize Rows ----

# summarize_row_df <-
#     function(name,
#              label,
#              indent,
#              depth,
#              rowtype,
#              indent_mod,
#              level) {
#         data.frame(
#             name = name,
#             label = label,
#             indent = indent,
#             depth = level,
#             rowtype = rowtype,
#             indent_mod = indent_mod,
#             level = level,
#             stringsAsFactors = FALSE
#         )
#     }

#' Summarize rows
#'
#' @inheritParams gen_args
#' @param depth (`numeric(1)`)\cr depth.
#' @param indent (`numeric(1)`)\cr indent.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#'
#' tbl <- build_table(lyt, iris2)
#'
#' @rdname int_methods
setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
  standardGeneric("summarize_rows_inner")
})

#' @rdname int_methods
setMethod(
  "summarize_rows_inner", "TableTree",
  function(obj, depth = 0, indent = 0) {
    indent <- max(0L, indent + indent_mod(obj))

    lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent)
    if (!is.null(lr)) {
      ret <- list(lr)
    } else {
      ret <- list()
    }

    indent <- indent + (!is.null(lr))

    ctab <- content_table(obj)
    if (NROW(ctab)) {
      ct <- summarize_rows_inner(ctab,
        depth = depth,
        indent = indent + indent_mod(ctab)
      )
      ret <- c(ret, ct)
      indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab))
    }

    kids <- tree_children(obj)
    els <- lapply(tree_children(obj), summarize_rows_inner,
      depth = depth + 1, indent = indent
    )
    if (!are(kids, "TableRow")) {
      if (!are(kids, "VTableTree")) {
        ## hatchet job of a hack, wrap em just so we can unlist em all at
        ## the same level
        rowinds <- vapply(kids, is, NA, class2 = "TableRow")
        els[rowinds] <- lapply(els[rowinds], function(x) list(x))
      }
      els <- unlist(els, recursive = FALSE)
    }
    ret <- c(ret, els)
    ret
    ## df <- do.call(rbind, c(list(lr), list(ct), els))

    ## row.names(df) <- NULL
    ## df
  }
)

# Print Table Structure ----

#' Summarize table
#'
#' @param x (`VTableTree`)\cr a table object.
#' @param detail (`string`)\cr either `row` or `subtable`.
#'
#' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`.
#'
#' @examplesIf require(dplyr)
#' library(dplyr)
#'
#' iris2 <- iris %>%
#'   group_by(Species) %>%
#'   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
#'   ungroup()
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("Species") %>%
#'   split_cols_by("group") %>%
#'   analyze(c("Sepal.Length", "Petal.Width"),
#'     afun = list_wrap_x(summary),
#'     format = "xx.xx"
#'   )
#'
#' tbl <- build_table(lyt, iris2)
#' tbl
#'
#' row_paths(tbl)
#'
#' table_structure(tbl)
#'
#' table_structure(tbl, detail = "row")
#'
#' @export
table_structure <- function(x, detail = c("subtable", "row")) {
  detail <- match.arg(detail)

  switch(detail,
    subtable = treestruct(x),
    row = table_structure_inner(x),
    stop("unsupported level of detail ", detail)
  )
}

#' @param obj (`VTableTree`)\cr a table object.
#' @param depth (`numeric(1)`)\cr depth in tree.
#' @param indent (`numeric(1)`)\cr indent.
#' @param print_indent (`numeric(1)`)\cr indent for printing.
#'
#' @rdname int_methods
setGeneric(
  "table_structure_inner",
  function(obj,
           depth = 0,
           indent = 0,
           print_indent = 0) {
    standardGeneric("table_structure_inner")
  }
)

scat <- function(..., indent = 0, newline = TRUE) {
  txt <- paste(..., collapse = "", sep = "")

  cat(indent_string(txt, indent))

  if (newline) cat("\n")
}

## helper functions
obj_visible <- function(x) {
  x@visible
}

is_empty_labelrow <- function(x) {
  obj_label(x) == "" && !labelrow_visible(x)
}

is_empty_ElementaryTable <- function(x) {
  length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x))
}

#' @param object (`VTableTree`)\cr a table object.
#'
#' @rdname int_methods
#' @export
setGeneric("str", function(object, ...) {
  standardGeneric("str")
})

#' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike
#'   the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects.
#'
#' @rdname int_methods
#' @export
setMethod(
  "str", "VTableTree",
  function(object, max.level = 3L, ...) {
    utils::str(object, max.level = max.level, ...)
    warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
      "See table_structure(.) for a summary of table struture intended for end users.",
      call. = FALSE
    )
    invisible(NULL)
  }
)

#' @inheritParams table_structure_inner
#' @rdname int_methods
setMethod(
  "table_structure_inner", "TableTree",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    indent <- indent + indent_mod(obj)

    scat("TableTree: ", "[", obj_name(obj), "] (",
      obj_label(obj), ")",
      indent = print_indent
    )

    table_structure_inner(
      tt_labelrow(obj), depth, indent,
      print_indent + 1
    )

    ctab <- content_table(obj)
    visible_content <- if (is_empty_ElementaryTable(ctab)) {
      # scat("content: -", indent = print_indent + 1)
      FALSE
    } else {
      scat("content:", indent = print_indent + 1)
      table_structure_inner(ctab,
        depth = depth,
        indent = indent + indent_mod(ctab),
        print_indent = print_indent + 2
      )
    }

    if (length(tree_children(obj)) == 0) {
      scat("children: - ", indent = print_indent + 1)
    } else {
      scat("children: ", indent = print_indent + 1)
      lapply(tree_children(obj), table_structure_inner,
        depth = depth + 1,
        indent = indent + visible_content * (1 + indent_mod(ctab)),
        print_indent = print_indent + 2
      )
    }

    invisible(NULL)
  }
)

#' @rdname int_methods
setMethod(
  "table_structure_inner", "ElementaryTable",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    scat("ElementaryTable: ", "[", obj_name(obj),
      "] (", obj_label(obj), ")",
      indent = print_indent
    )

    indent <- indent + indent_mod(obj)

    table_structure_inner(
      tt_labelrow(obj), depth,
      indent, print_indent + 1
    )

    if (length(tree_children(obj)) == 0) {
      scat("children: - ", indent = print_indent + 1)
    } else {
      scat("children: ", indent = print_indent + 1)
      lapply(tree_children(obj), table_structure_inner,
        depth = depth + 1, indent = indent,
        print_indent = print_indent + 2
      )
    }

    invisible(NULL)
  }
)

#' @rdname int_methods
setMethod(
  "table_structure_inner", "TableRow",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    scat(class(obj), ": ", "[", obj_name(obj), "] (",
      obj_label(obj), ")",
      indent = print_indent
    )

    indent <- indent + indent_mod(obj)

    invisible(NULL)
  }
)

#' @rdname int_methods
setMethod(
  "table_structure_inner", "LabelRow",
  function(obj, depth = 0, indent = 0, print_indent = 0) {
    indent <- indent + indent_mod(obj)

    txtvis <- if (!obj_visible(obj)) " - <not visible>" else ""

    scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
      txtvis,
      indent = print_indent
    )

    obj_visible(obj)
  }
)

# Generics and how they are used directly -------------------------------------

## check_validsplit - Check if the split is valid for the data, error if not

## .apply_spl_extras - Generate Extras

## .apply_spl_datapart - generate data partition

## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values

setGeneric(
  ".applysplit_rawvals",
  function(spl, df) standardGeneric(".applysplit_rawvals")
)

setGeneric(
  ".applysplit_datapart",
  function(spl, df, vals) standardGeneric(".applysplit_datapart")
)

setGeneric(
  ".applysplit_extras",
  function(spl, df, vals) standardGeneric(".applysplit_extras")
)

setGeneric(
  ".applysplit_partlabels",
  function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels")
)

setGeneric(
  "check_validsplit",
  function(spl, df) standardGeneric("check_validsplit")
)

setGeneric(
  ".applysplit_ref_vals",
  function(spl, df, vals) standardGeneric(".applysplit_ref_vals")
)
# Custom split fncs ------------------------------------------------------------
#' Custom split functions
#'
#' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set
#' of incoming data and a split object, and return "splits" of that data.
#'
#' @section Custom Splitting Function Details:
#'
#' User-defined custom split functions can perform any type of computation on the incoming data provided that they
#' meet the requirements for generating "splits" of the incoming data based on the split object.
#'
#' Split functions are functions that accept:
#'   \describe{
#'     \item{df}{a `data.frame` of incoming data to be split.}
#'     \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about,
#'       but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting
#'       table.}
#'     \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these.
#'       Should be `NULL` in most cases and can usually be ignored.}
#'     \item{labels}{any pre-calculated value labels. Same as above for `values`.}
#'     \item{trim}{if `TRUE`, resulting splits that are empty are removed.}
#'     \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively
#'       arrived at `df`.}
#'   }
#'
#' The function must then output a named `list` with the following elements:
#'
#'   \describe{
#'     \item{values}{the vector of all values corresponding to the splits of `df`.}
#'     \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.}
#'     \item{labels}{a character vector giving a string label for each value listed in the `values` element above.}
#'     \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions
#'       whenever they are executed on the corresponding element of `datasplit` or a subset thereof.}
#'   }
#'
#' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming
#' data before they are called or their outputs.
#'
#' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of
#'   pre-defined split functions.
#'
#' @examples
#' # Example of a picky split function. The number of values in the column variable
#' # var decrees if we are going to print also the column with all observation
#' # or not.
#'
#' picky_splitter <- function(var) {
#'   # Main layout function
#'   function(df, spl, vals, labels, trim) {
#'     orig_vals <- vals
#'
#'     # Check for number of levels if all are selected
#'     if (is.null(vals)) {
#'       vec <- df[[var]]
#'       vals <- unique(vec)
#'     }
#'
#'     # Do a split with or without All obs
#'     if (length(vals) == 1) {
#'       do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim)
#'     } else {
#'       fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE)
#'       fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim)
#'     }
#'   }
#' }
#'
#' # Data sub-set
#' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F"))
#' d1 <- subset(d1, SEX %in% c("M", "F"))
#' d1$SEX <- factor(d1$SEX)
#'
#' # This table uses the number of values in the SEX column to add the overall col or not
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM", split_fun = drop_split_levels) %>%
#'   split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>%
#'   analyze("AGE", show_labels = "visible")
#' tbl <- build_table(lyt, d1)
#' tbl
#'
#' @name custom_split_funs
NULL

## do various cleaning, and naming, plus
## ensure partinfo$values contains SplitValue objects only
.fixupvals <- function(partinfo) {
  if (is.factor(partinfo$labels)) {
    partinfo$labels <- as.character(partinfo$labels)
  }

  vals <- partinfo$values
  if (is.factor(vals)) {
    vals <- levels(vals)[vals]
  }
  extr <- partinfo$extras
  dpart <- partinfo$datasplit
  labels <- partinfo$labels
  if (is.null(labels)) {
    if (!is.null(names(vals))) {
      labels <- names(vals)
    } else if (!is.null(names(dpart))) {
      labels <- names(dpart)
    } else if (!is.null(names(extr))) {
      labels <- names(extr)
    }
  }

  subsets <- partinfo$subset_exprs
  if (is.null(subsets)) {
    subsets <- vector(mode = "list", length = length(vals))
    ## use labels here cause we already did all that work
    ## to get the names on the labels vector right
    names(subsets) <- names(labels)
  }

  if (is.null(vals) && !is.null(extr)) {
    vals <- seq_along(extr)
  }

  if (length(vals) == 0) {
    stopifnot(length(extr) == 0)
    return(partinfo)
  }
  ## length(vals) > 0 from here down

  if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) {
    if (!is.null(extr)) {
      ## in_ref_cols is in here for some reason even though its already in the SplitValue object.
      ## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598
      ## the if is a bandaid.
      ## XXX FIXME RIGHT
      sq <- seq_along(vals)
      if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) {
        warning(
          "Got a partinfo list with values that are ",
          "already SplitValue objects and non-null extras ",
          "element. This shouldn't happen"
        )
      }
    }
  } else {
    if (is.null(extr)) {
      extr <- rep(list(list()), length(vals))
    }
    vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets)
  }
  ## we're done with this so take it off
  partinfo$extras <- NULL

  vnames <- value_names(vals)
  names(vals) <- vnames
  partinfo$values <- vals

  if (!identical(names(dpart), vnames)) {
    names(dpart) <- vnames
    partinfo$datasplit <- dpart
  }

  partinfo$labels <- labels

  stopifnot(length(unique(sapply(partinfo, NROW))) == 1)
  partinfo
}

.add_ref_extras <- function(spl, df, partinfo) {
  ## this is only the .in_ref_col booleans
  refvals <- .applysplit_ref_vals(spl, df, partinfo$values)
  ref_ind <- which(unlist(refvals))
  stopifnot(length(ref_ind) == 1)

  vnames <- value_names(partinfo$values)
  if (is.null(partinfo$extras)) {
    names(refvals) <- vnames
    partinfo$extras <- refvals
  } else {
    newextras <- mapply(
      function(old, incol, ref_full) {
        c(old, list(
          .in_ref_col = incol,
          .ref_full = ref_full
        ))
      },
      old = partinfo$extras,
      incol = unlist(refvals),
      MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]),
      SIMPLIFY = FALSE
    )
    names(newextras) <- vnames
    partinfo$extras <- newextras
  }
  partinfo
}

#' Apply basic split (for use in custom split functions)
#'
#' This function is intended for use inside custom split functions. It applies the current split *as if it had no
#' custom splitting function* so that those default splits can be further manipulated.
#'
#' @inheritParams gen_args
#' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`.
#' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should
#'   almost always be the case.
#' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to
#'   `FALSE`.
#'
#' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs].
#'
#' @examples
#' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
#'   ret <- do_base_split(spl, df, vals, labels, trim)
#'   if (NROW(df) == 0) {
#'     ret <- lapply(ret, function(x) x[1])
#'   }
#'   ret
#' }
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"),
#'     varlabels = c("N", "E", "BMR1"),
#'     split_fun = uneven_splfun
#'   ) %>%
#'   analyze_colvars(list(
#'     USUBJID = function(x, ...) length(unique(x)),
#'     AESEQ = max,
#'     BMRKR1 = mean
#'   ))
#'
#' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2))
#' tbl
#'
#' @export
do_base_split <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
  spl2 <- spl
  split_fun(spl2) <- NULL
  do_split(spl2,
    df = df, vals = vals, labels = labels, trim = trim,
    spl_context = NULL
  )
}

### NB This is called at EACH level of recursive splitting
do_split <- function(spl,
                     df,
                     vals = NULL,
                     labels = NULL,
                     trim = FALSE,
                     spl_context) {
  ## this will error if, e.g., df doesn't have columns
  ## required by spl, or generally any time the spl
  ## can't be applied to df
  check_validsplit(spl, df)
  ## note the <- here!!!
  if (!is.null(splfun <- split_fun(spl))) {
    ## Currently the contract is that split_functions take df, vals, labels and
    ## return list(values=., datasplit=., labels = .), optionally with
    ## an additional extras element
    if (func_takes(splfun, ".spl_context")) {
      ret <- tryCatch(
        splfun(df, spl, vals, labels,
          trim = trim,
          .spl_context = spl_context
        ),
        error = function(e) e
      ) ## rawvalues(spl_context ))
    } else {
      ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim),
        error = function(e) e
      )
    }
    if (is(ret, "error")) {
      stop(
        "Error applying custom split function: ", ret$message, "\n\tsplit: ",
        class(spl), " (", payloadmsg(spl), ")\n",
        "\toccured at path: ",
        spl_context_to_disp_path(spl_context), "\n"
      )
    }
  } else {
    ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim)
  }

  ## this adds .ref_full and .in_ref_col
  if (is(spl, "VarLevWBaselineSplit")) {
    ret <- .add_ref_extras(spl, df, ret)
  }

  ## this:
  ## - guarantees that ret$values contains SplitValue objects
  ## - removes the extras element since its redundant after the above
  ## - Ensures datasplit and values lists are named according to labels
  ## - ensures labels are character not factor
  ret <- .fixupvals(ret)
  ## we didn't put this in .fixupvals because that get called withint he split functions
  ## created by make_split_fun and its not clear this check should be happening then.
  if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE
    stop(
      "Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ",
      class(spl), " (", payloadmsg(spl), ")\n",
      "\toccured at path: ",
      spl_context_to_disp_path(spl_context), "\n"
    )
  }
  ret
}

.apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
  if (is.null(vals)) {
    vals <- .applysplit_rawvals(spl, df)
  }
  extr <- .applysplit_extras(spl, df, vals)

  if (is.null(vals)) {
    return(list(
      values = list(),
      datasplit = list(),
      labels = list(),
      extras = list()
    ))
  }

  dpart <- .applysplit_datapart(spl, df, vals)

  if (is.null(labels)) {
    labels <- .applysplit_partlabels(spl, df, vals, labels)
  } else {
    stopifnot(names(labels) == names(vals))
  }
  ## get rid of columns that would not have any
  ## observations.
  ##
  ## But only if there were any rows to start with
  ## if not we're in a manually constructed table
  ## column tree
  if (trim) {
    hasdata <- sapply(dpart, function(x) nrow(x) > 0)
    if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties
      dpart <- dpart[hasdata]
      vals <- vals[hasdata]
      extr <- extr[hasdata]
      labels <- labels[hasdata]
    }
  }

  if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) {
    vord <- seq_along(vals)
  } else {
    vord <- match(
      spl_child_order(spl),
      vals
    )
    vord <- vord[!is.na(vord)]
  }

  ## FIXME: should be an S4 object, not a list
  ret <- list(
    values = vals[vord],
    datasplit = dpart[vord],
    labels = labels[vord],
    extras = extr[vord]
  )
  ret
}

.checkvarsok <- function(spl, df) {
  vars <- spl_payload(spl)
  ## could be multiple vars in the future?
  ## no reason not to make that work here now.
  if (!all(vars %in% names(df))) {
    stop(
      " variable(s) [",
      paste(setdiff(vars, names(df)),
        collapse = ", "
      ),
      "] not present in data. (",
      class(spl), ")"
    )
  }
  invisible(NULL)
}

### Methods to verify a split appears to be valid, applicable
### to the ***current subset*** of the df.
###
### This is called at each level of recursive splitting so
### do NOT make it check, e.g., if the ref_group level of
### a factor is present in the data, because it may not be.

setMethod(
  "check_validsplit", "VarLevelSplit",
  function(spl, df) {
    .checkvarsok(spl, df)
  }
)

setMethod(
  "check_validsplit", "MultiVarSplit",
  function(spl, df) {
    .checkvarsok(spl, df)
  }
)

setMethod(
  "check_validsplit", "VAnalyzeSplit",
  function(spl, df) {
    if (!is.na(spl_payload(spl))) {
      .checkvarsok(spl, df)
    } else {
      TRUE
    }
  }
)

setMethod(
  "check_validsplit", "CompoundSplit",
  function(spl, df) {
    all(sapply(spl_payload(spl), df))
  }
)

## default does nothing, add methods as they become
## required
setMethod(
  "check_validsplit", "Split",
  function(spl, df) invisible(NULL)
)

setMethod(
  ".applysplit_rawvals", "VarLevelSplit",
  function(spl, df) {
    varvec <- df[[spl_payload(spl)]]
    if (is.factor(varvec)) {
      levels(varvec)
    } else {
      unique(varvec)
    }
  }
)

setMethod(
  ".applysplit_rawvals", "MultiVarSplit",
  function(spl, df) {
    ##    spl_payload(spl)
    spl_varnames(spl)
  }
)

setMethod(
  ".applysplit_rawvals", "AllSplit",
  function(spl, df) obj_name(spl)
) # "all obs")

setMethod(
  ".applysplit_rawvals", "ManualSplit",
  function(spl, df) spl@levels
)

## setMethod(".applysplit_rawvals", "NULLSplit",
##           function(spl, df) "")

setMethod(
  ".applysplit_rawvals", "VAnalyzeSplit",
  function(spl, df) spl_payload(spl)
)

## formfactor here is gross we're gonna have ot do this
## all again in tthe data split part :-/
setMethod(
  ".applysplit_rawvals", "VarStaticCutSplit",
  function(spl, df) {
    spl_cutlabels(spl)
  }
)

setMethod(
  ".applysplit_datapart", "VarLevelSplit",
  function(spl, df, vals) {
    if (!(spl_payload(spl) %in% names(df))) {
      stop(
        "Attempted to split on values of column (", spl_payload(spl),
        ") not present in the data"
      )
    }
    ret <- lapply(seq_along(vals), function(i) {
      spl_col <- df[[spl_payload(spl)]]
      df[!is.na(spl_col) & spl_col == vals[[i]], ]
    })
    names(ret) <- as.character(vals)
    ret
  }
)

setMethod(
  ".applysplit_datapart", "MultiVarSplit",
  function(spl, df, vals) {
    allvnms <- spl_varnames(spl)
    if (!is.null(vals) && !identical(allvnms, vals)) {
      incl <- match(vals, allvnms)
    } else {
      incl <- seq_along(allvnms)
    }
    vars <- spl_payload(spl)[incl]
    ## don't remove  nas
    ## ret = lapply(vars, function(cl) {
    ##     df[!is.na(df[[cl]]),]
    ## })
    ret <- rep(list(df), length(vars))
    names(ret) <- vals
    ret
  }
)

setMethod(
  ".applysplit_datapart", "AllSplit",
  function(spl, df, vals) list(df)
)

## ## not sure I need this
setMethod(
  ".applysplit_datapart", "ManualSplit",
  function(spl, df, vals) rep(list(df), times = length(vals))
)

## setMethod(".applysplit_datapart", "NULLSplit",
##           function(spl, df, vals) list(df[FALSE,]))

setMethod(
  ".applysplit_datapart", "VarStaticCutSplit",
  function(spl, df, vals) {
    #  lbs = spl_cutlabels(spl)
    var <- spl_payload(spl)
    varvec <- df[[var]]
    cts <- spl_cuts(spl)
    cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)
    split(df, cfct, drop = FALSE)
  }
)

setMethod(
  ".applysplit_datapart", "CumulativeCutSplit",
  function(spl, df, vals) {
    #  lbs = spl_cutlabels(spl)
    var <- spl_payload(spl)
    varvec <- df[[var]]
    cts <- spl_cuts(spl)
    cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)
    ret <- lapply(
      seq_len(length(levels(cfct))),
      function(i) df[as.integer(cfct) <= i, ]
    )
    names(ret) <- levels(cfct)
    ret
  }
)

## XXX TODO *CutSplit Methods

setClass("NullSentinel", contains = "NULL")
nullsentinel <- new("NullSentinel")
noarg <- function() nullsentinel

## Extras generation methods
setMethod(
  ".applysplit_extras", "Split",
  function(spl, df, vals) {
    splex <- split_exargs(spl)
    nvals <- length(vals)
    lapply(seq_len(nvals), function(vpos) {
      one_ex <- lapply(splex, function(arg) {
        if (length(arg) >= vpos) {
          arg[[vpos]]
        } else {
          noarg()
        }
      })
      names(one_ex) <- names(splex)
      one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")]
      one_ex
    })
  }
)

setMethod(
  ".applysplit_ref_vals", "Split",
  function(spl, df, vals) rep(list(NULL), length(vals))
)

setMethod(
  ".applysplit_ref_vals", "VarLevWBaselineSplit",
  function(spl, df, vals) {
    bl_level <- spl@ref_group_value # XXX XXX
    vnames <- value_names(vals)
    ret <- lapply(vnames, function(vl) {
      list(.in_ref_col = vl == bl_level)
    })
    names(ret) <- vnames
    ret
  }
)

## XXX TODO FIXME
setMethod(
  ".applysplit_partlabels", "Split",
  function(spl, df, vals, labels) as.character(vals)
)

setMethod(
  ".applysplit_partlabels", "VarLevelSplit",
  function(spl, df, vals, labels) {
    varname <- spl_payload(spl)
    vlabelname <- spl_labelvar(spl)
    varvec <- df[[varname]]
    ## we used to check if vals was NULL but
    ## this is called after a short-circuit return in .apply_split_inner in that
    ## case
    ## so vals is guaranteed to be non-null here
    if (is.null(labels)) {
      if (varname == vlabelname) {
        labels <- vals
      } else {
        labfact <- is.factor(df[[vlabelname]])
        lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL
        labels <- sapply(vals, function(v) {
          vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE])
          ## TODO remove this once 1-to-1 value-label map is enforced
          ## elsewhere.
          stopifnot(length(vlabel) < 2)
          if (length(vlabel) == 0) {
            vlabel <- ""
          } else if (labfact) {
            vlabel <- lablevs[vlabel]
          }
          vlabel
        })
      }
    }
    names(labels) <- as.character(vals)
    labels
  }
)

setMethod(
  ".applysplit_partlabels", "MultiVarSplit",
  function(spl, df, vals, labels) value_labels(spl)
)

make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals,
                              subset_exprs) {
  if (length(vals) == 0) {
    return(vals)
  }

  if (is(extrs, "AsIs")) {
    extrs <- unclass(extrs)
  }
  ## if(are(vals, "SplitValue")) {

  ##     return(vals)
  ## }

  mapply(SplitValue,
    val = vals, extr = extrs,
    label = labels,
    sub_expr = subset_exprs,
    SIMPLIFY = FALSE
  )
}

# as_result_df ------------------------------------------------------------
#' Generate a result data frame
#'
#' Collection of utilities to extract `data.frame` objects from `TableTree` objects.
#'
#' @inheritParams gen_args
#' @param spec (`function`)\cr function that generates the result data frame from a table (`TableTree`).
#'   It defaults to `NULL`, for standard processing.
#' @param expand_colnames (`flag`)\cr when `TRUE`, the result data frame will have expanded column
#'   names above the usual output. This is useful when the result data frame is used for further processing.
#' @param data_format (`string`)\cr the format of the data in the result data frame. It can be one value
#'   between `"full_precision"` (default), `"strings"`, and `"numeric"`. The last two values show the numeric
#'   data with the visible precision.
#' @param make_ard (`flag`)\cr when `TRUE`, the result data frame will have only one statistic per row.
#' @param keep_label_rows (`flag`)\cr when `TRUE`, the result data frame will have all labels
#'   as they appear in the final table.
#' @param simplify (`flag`)\cr when `TRUE`, the result data frame will have only visible labels and
#'   result columns. Consider showing also label rows with `keep_label_rows = TRUE`. This output can be
#'   used again to create a `TableTree` object with [df_to_tt()].
#' @param ... additional arguments passed to spec-specific result data frame function (`spec`).
#'
#' @return
#' * `as_result_df` returns a result `data.frame`.
#'
#' @seealso [df_to_tt()] when using `simplify = TRUE` and [formatters::make_row_df()] to have a
#'   comprehensive view of the hierarchical structure of the rows.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("STRATA1") %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' as_result_df(tbl, simplify = TRUE)
#'
#' @name data.frame_export
#' @export
as_result_df <- function(tt, spec = NULL,
                         data_format = c("full_precision", "strings", "numeric"),
                         make_ard = FALSE,
                         expand_colnames = FALSE,
                         keep_label_rows = FALSE,
                         simplify = FALSE,
                         ...) {
  data_format <- data_format[[1]]
  checkmate::assert_class(tt, "VTableTree")
  checkmate::assert_function(spec, null.ok = TRUE)
  checkmate::assert_choice(data_format[[1]], choices = eval(formals(as_result_df)[["data_format"]]))
  checkmate::assert_flag(make_ard)
  checkmate::assert_flag(expand_colnames)
  checkmate::assert_flag(keep_label_rows)
  checkmate::assert_flag(simplify)

  if (nrow(tt) == 0) {
    return(sanitize_table_struct(tt))
  }

  if (make_ard) {
    simplify <- FALSE
    expand_colnames <- TRUE
    keep_label_rows <- FALSE
  }

  if (is.null(spec)) {
    raw_cvals <- cell_values(tt)
    ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values
    ## rather than a list of length 1 representing the single row. This is bad but may not be changeable
    ## at this point.
    if (nrow(tt) == 1 && length(raw_cvals) > 1) {
      raw_cvals <- list(raw_cvals)
    }

    # Flatten the list of lists (rows) of cell values into a data frame
    cellvals <- as.data.frame(do.call(rbind, raw_cvals))
    row.names(cellvals) <- NULL

    if (nrow(tt) == 1 && ncol(tt) == 1) {
      colnames(cellvals) <- names(raw_cvals)
    }

    if (data_format %in% c("strings", "numeric")) {
      # we keep previous calculations to check the format of the data
      mf_tt <- matrix_form(tt)
      mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1]
      mf_result_chars <- .remove_empty_elements(mf_result_chars)
      mf_result_numeric <- as.data.frame(
        .make_numeric_char_mf(mf_result_chars)
      )
      mf_result_chars <- as.data.frame(mf_result_chars)
      if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) {
        stop(
          "The extracted numeric data.frame does not have the same dimension of the",
          " cell values extracted with cell_values(). This is a bug. Please report it."
        ) # nocov
      }
      if (data_format == "strings") {
        colnames(mf_result_chars) <- colnames(cellvals)
        cellvals <- mf_result_chars
      } else {
        colnames(mf_result_numeric) <- colnames(cellvals)
        cellvals <- mf_result_numeric
      }
    }

    rdf <- make_row_df(tt)
    cinfo_df <- col_info(tt)
    ci_coltree <- coltree(cinfo_df)
    column_split_names <- .get_column_split_name(ci_coltree) # used only in make_ard

    df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
    # Removing initial root elements from path (out of the loop -> right maxlen)
    df$path <- lapply(df$path, .remove_root_elems_from_path,
      which_root_name = c("root", "rbind_root"),
      all = TRUE
    )
    maxlen <- max(lengths(df$path))

    # Loop for metadata (path and details from make_row_df)
    metadf <- do.call(
      rbind.data.frame,
      lapply(
        seq_len(NROW(df)),
        function(ii) {
          handle_rdf_row(df[ii, ], maxlen = maxlen)
        }
      )
    )

    # Should we keep label rows with NAs instead of values?
    if (keep_label_rows) {
      cellvals_mat_struct <- as.data.frame(
        matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals))
      )
      colnames(cellvals_mat_struct) <- colnames(cellvals)
      cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals
      ret <- cbind(metadf, cellvals_mat_struct)
    } else {
      ret <- cbind(
        metadf[metadf$node_class != "LabelRow", ],
        cellvals
      )
    }

    # If we want to expand colnames
    if (expand_colnames) {
      col_name_structure <- .get_formatted_colnames(clayout(tt))
      number_of_non_data_cols <- which(colnames(ret) == "node_class")
      if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
        stop(
          "When expanding colnames structure, we were not able to find the same",
          " number of columns as in the result data frame. This is a bug. Please report it."
        ) # nocov
      }

      buffer_rows_for_colnames <- matrix(
        rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
        nrow = NROW(col_name_structure)
      )

      header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure))
      colnames(header_colnames_matrix) <- colnames(ret)

      count_row <- NULL
      if (disp_ccounts(tt)) {
        ccounts <- col_counts(tt)
        if (data_format == "strings") {
          ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ]
          ccounts <- .remove_empty_elements(ccounts)
        }
        count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
        header_colnames_matrix <- rbind(header_colnames_matrix, count_row)
      }
      ret <- rbind(header_colnames_matrix, ret)
    }

    # ARD part for one stat per row
    if (make_ard) {
      # Unnecessary columns
      ret_tmp <- ret[, !colnames(ret) %in% c("row_num", "is_group_summary", "node_class")]

      # Indexes of real columns (visible in the output, but no row names)
      only_col_indexes <- seq(which(colnames(ret_tmp) == "label_name") + 1, ncol(ret_tmp))

      # Core row names
      col_label_rows <- grepl("<only_for_column_*", ret_tmp$avar_name)
      core_row_names <- ret_tmp[!col_label_rows, -only_col_indexes]

      # Moving colnames to rows (flattening)
      ret_w_cols <- NULL
      for (col_i in only_col_indexes) {
        tmp_ret_by_col_i <- cbind(
          group1 = column_split_names[[ret_tmp[, col_i][[1]]]],
          group1_level = ret_tmp[, col_i][[1]],
          # instead of avar_name  row_name       label_name ("variable_label" is not present in ARDs)
          setNames(core_row_names, c("variable", "variable_level", "variable_label")), # missing stat_name xxx
          stat = I(setNames(ret_tmp[!col_label_rows, col_i], NULL))
        )

        ret_w_cols <- rbind(ret_w_cols, tmp_ret_by_col_i)
      }

      ret <- ret_w_cols
    }

    # Simplify the result data frame
    out <- if (simplify) {
      .simplify_result_df(ret)
    } else {
      ret
    }

    # take out rownames
    rownames(out) <- NULL
  } else {
    # Applying specs
    out <- spec(tt, ...)
  }

  out
}

# Helper function to get column split names
.get_column_split_name <- function(ci_coltree) {
  # ci stands for column information
  if (is(ci_coltree, "LayoutAxisTree")) {
    kids <- tree_children(ci_coltree)
    return(unlist(lapply(kids, .get_column_split_name)))
  }
  sapply(pos_splits(tree_pos(ci_coltree)), spl_payload)
}

# Function that selects specific outputs from the result data frame
.simplify_result_df <- function(df) {
  col_df <- colnames(df)
  if (!all(c("label_name", "node_class") %in% col_df)) {
    stop("Please simplify the result data frame only when it has 'label_name' and 'node_class' columns.")
  }
  label_names_col <- which(col_df == "label_name")
  result_cols <- seq(which(col_df == "node_class") + 1, length(col_df))

  df[, c(label_names_col, result_cols)]
}

.remove_empty_elements <- function(char_df) {
  if (is.null(dim(char_df))) {
    return(char_df[nzchar(char_df, keepNA = TRUE)])
  }

  apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)])
}

# Helper function to make the character matrix numeric
.make_numeric_char_mf <- function(char_df) {
  if (is.null(dim(char_df))) {
    return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+")))
  }

  ret <- apply(char_df, 2, function(col_i) {
    lapply(
      stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"),
      as.numeric
    )
  })

  do.call(cbind, ret)
}

make_result_df_md_colnames <- function(maxlen) {
  spllen <- floor((maxlen - 2) / 2)
  ret <- character()
  if (spllen > 0) {
    ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_")
  }
  ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
}

do_label_row <- function(rdfrow, maxlen) {
  pth <- rdfrow$path[[1]]
  # Adjusting for the fact that we have two columns for each split
  extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2

  # Special cases with hidden labels
  if (length(pth) %% 2 == 1) {
    extra_nas_from_splits <- extra_nas_from_splits + 1
  }

  c(
    as.list(pth[seq_len(length(pth) - 1)]),
    as.list(replicate(extra_nas_from_splits, list(NA_character_))),
    as.list(tail(pth, 1)),
    list(
      label_name = rdfrow$label,
      row_num = rdfrow$abs_rownumber,
      content = FALSE,
      node_class = rdfrow$node_class
    )
  )
}

do_content_row <- function(rdfrow, maxlen) {
  pth <- rdfrow$path[[1]]
  contpos <- which(pth == "@content")

  seq_before <- seq_len(contpos - 1)

  c(
    as.list(pth[seq_before]),
    as.list(replicate(maxlen - contpos, list(NA_character_))),
    list(tail(pth, 1)),
    list(
      label_name = rdfrow$label,
      row_num = rdfrow$abs_rownumber,
      content = TRUE,
      node_class = rdfrow$node_class
    )
  )
}

do_data_row <- function(rdfrow, maxlen) {
  pth <- rdfrow$path[[1]]
  pthlen <- length(pth)
  ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame
  if (pthlen %% 2 == 1) {
    pth <- pth[-1 * (pthlen - 2)]
  }
  pthlen_new <- length(pth)
  if (maxlen == 1) pthlen_new <- 3
  c(
    as.list(pth[seq_len(pthlen_new - 2)]),
    replicate(maxlen - pthlen, list(NA_character_)),
    as.list(tail(pth, 2)),
    list(
      label_name = rdfrow$label,
      row_num = rdfrow$abs_rownumber,
      content = FALSE,
      node_class = rdfrow$node_class
    )
  )
}

.remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
  any_root_paths <- path[1] %in% which_root_name
  if (any_root_paths) {
    if (isTRUE(all)) {
      # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later)
      root_indices <- which(path %in% which_root_name)
      if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
        end_point_root_headers <- which(diff(root_indices) > 1)[1]
      } else {
        end_point_root_headers <- length(root_indices)
      }
      root_path_to_remove <- seq_len(end_point_root_headers)
    } else {
      root_path_to_remove <- 1
    }
    path <- path[-root_path_to_remove]
  }

  # Fix for very edge case where we have only root elements
  if (length(path) == 0) {
    path <- which_root_name[1]
  }

  path
}

handle_rdf_row <- function(rdfrow, maxlen) {
  nclass <- rdfrow$node_class

  ret <- switch(nclass,
    LabelRow = do_label_row(rdfrow, maxlen),
    ContentRow = do_content_row(rdfrow, maxlen),
    DataRow = do_data_row(rdfrow, maxlen),
    stop("Unrecognized node type in row dataframe, unable to generate result data frame")
  )
  setNames(ret, make_result_df_md_colnames(maxlen))
}

# Helper recurrent function to get the column names for the result data frame from the VTableTree
.get_formatted_colnames <- function(clyt) {
  ret <- obj_label(clyt)
  if (!nzchar(ret)) {
    ret <- NULL
  }
  if (is.null(tree_children(clyt))) {
    return(ret)
  } else {
    ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames)))
    colnames(ret) <- NULL
    rownames(ret) <- NULL
    return(ret)
  }
}
# path_enriched_df ------------------------------------------------------------
#
#' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`.
#'
#' @param path_fun (`function`)\cr function to transform paths into single-string row/column names.
#' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to
#'   `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`.
#'
#' @return
#' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by
#'   the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed
#'   by `path_fun`).
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#' path_enriched_df(tbl)
#'
#' @export
path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
  rdf <- make_row_df(tt)
  cdf <- make_col_df(tt)
  cvs <- as.data.frame(do.call(rbind, cell_values(tt)))
  cvs <- as.data.frame(lapply(cvs, value_fun))
  row.names(cvs) <- NULL
  colnames(cvs) <- path_fun(cdf$path)
  preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path)
  cbind.data.frame(row_path = preppaths, cvs)
}

.collapse_char <- "|"
.collapse_char_esc <- "\\|"

collapse_path <- function(paths) {
  if (is.list(paths)) {
    return(vapply(paths, collapse_path, ""))
  }
  paste(paths, collapse = .collapse_char)
}

collapse_values <- function(colvals) {
  if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1))
    return(colvals)
  } else if (all(vapply(colvals, length, 1L) == 1)) {
    return(unlist(colvals))
  }
  vapply(colvals, paste, "", collapse = .collapse_char)
}

#' Score functions for sorting `TableTrees`
#'
#' @inheritParams gen_args
#'
#' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting.
#'
#' @export
#' @rdname score_funs
cont_n_allcols <- function(tt) {
  ctab <- content_table(tt)
  if (NROW(ctab) == 0) {
    stop(
      "cont_n_allcols score function used at subtable [",
      obj_name(tt), "] that has no content table."
    )
  }
  sum(sapply(
    row_values(tree_children(ctab)[[1]]),
    function(cv) cv[1]
  ))
}

#' @param j (`numeric(1)`)\cr index of column used for scoring.
#'
#' @seealso For examples and details, please read the documentation for [sort_at_path()] and the
#' [Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)
#' vignette.
#'
#' @export
#' @rdname score_funs
cont_n_onecol <- function(j) {
  function(tt) {
    ctab <- content_table(tt)
    if (NROW(ctab) == 0) {
      stop(
        "cont_n_allcols score function used at subtable [",
        obj_name(tt), "] that has no content table."
      )
    }
    row_values(tree_children(ctab)[[1]])[[j]][1]
  }
}

#' Sorting a table at a specific path
#'
#' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.
#'
#' @inheritParams gen_args
#' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position
#'   at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value
#'   to be sorted.
#' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If
#'   unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are
#'   characters.
#' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to
#'   `"omit"`, which removes them. Other allowed values are `"last"`  and `"first"`, which indicate where `NA` scores
#'   should be placed in the order.
#' @param .prev_path (`character`)\cr internal detail, do not set manually.
#'
#' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done
#'   at `path`.
#'
#' @details
#' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"`
#' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting
#' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting
#' operations.
#'
#' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus
#' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper
#' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare
#' it, which we encourage users to avoid.
#'
#' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means
#' that each child at that step will be *separately* sorted based on `scorefun` and the remaining `path` entries. This
#' can occur multiple times in a path.
#'
#' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by
#' [formatters::make_row_df()] with the `visible_only` argument set to `FALSE`. It can also be inferred from the
#' summary given by [table_structure()].
#'
#' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related
#' vignette
#' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html))
#' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also
#' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and
#' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is
#' commonly produced by calling one of the various [analyze()] instances.
#'
#' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows
#' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some
#' useful descriptor and accessor functions (coming from related vignette):
#'  - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values.
#'  - [formatters::obj_name()] - Retrieves the name of an object. Note this can differ from the label that is
#'  displayed (if any is)  when printing.
#'  - [formatters::obj_label()] - Retrieves the display label of an object. Note this can differ from the name that
#'  appears in the path.
#'  - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows).
#'  - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix
#'    thereof, though that should not happen in practice).
#'
#' @seealso
#' * Score functions [cont_n_allcols()] and [cont_n_onecol()].
#' * [formatters::make_row_df()] and [table_structure()] for pathing information.
#' * [tt_at_path()] to select a table's (sub)structure at a given path.
#'
#' @examples
#' # Creating a table to sort
#'
#' # Function that gives two statistics per table-tree "leaf"
#' more_analysis_fnc <- function(x) {
#'   in_rows(
#'     "median" = median(x),
#'     "mean" = mean(x),
#'     .formats = "xx.x"
#'   )
#' }
#'
#' # Main layout of the table
#' raw_lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by(
#'     "RACE",
#'     split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
#'   ) %>%
#'   summarize_row_groups() %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE", afun = more_analysis_fnc)
#'
#' # Creating the table and pruning empty and NAs
#' tbl <- build_table(raw_lyt, DM) %>%
#'   prune_table()
#'
#' # Peek at the table structure to understand how it is built
#' table_structure(tbl)
#'
#' #  Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for
#' # the ASIAN group/row-split. This uses content_table() accessor function as it
#' # is a "ContentRow". In this case, we also base our sorting only on the second column.
#' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
#'
#' # Custom scoring function that is working on "DataRow"s
#' scorefun <- function(tt) {
#'   # Here we could use browser()
#'   sum(unlist(row_values(tt))) # Different accessor function
#' }
#' # Sorting mean and median for all the AGE leaves!
#' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun)
#'
#' @export
sort_at_path <- function(tt,
                         path,
                         scorefun,
                         decreasing = NA,
                         na.pos = c("omit", "last", "first"),
                         .prev_path = character()) {
  if (NROW(tt) == 0) {
    return(tt)
  }

  ## XXX hacky fix this!!!
  ## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior
  if (path[1] == "root") {
    ## always remove first root element but only add it to
    ## .prev_path (used for error reporting) if it actually matched the name
    if (obj_name(tt) == "root") {
      .prev_path <- c(.prev_path, path[1])
    }
    path <- path[-1]
  }
  if (identical(obj_name(tt), path[1])) {
    .prev_path <- c(.prev_path, path[1])
    path <- path[-1]
  }

  curpath <- path
  subtree <- tt
  backpath <- c()
  count <- 0
  while (length(curpath) > 0) {
    curname <- curpath[1]
    oldkids <- tree_children(subtree)
    ## we sort each child separately based on the score function
    ## and the remaining path
    if (curname == "*") {
      oldnames <- vapply(oldkids, obj_name, "")
      newkids <- lapply(
        seq_along(oldkids),
        function(i) {
          sort_at_path(oldkids[[i]],
            path = curpath[-1],
            scorefun = scorefun,
            decreasing = decreasing,
            na.pos = na.pos,
            ## its ok to modify the "path" here because its only ever used for
            ## informative error reporting.
            .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
          )
        }
      )
      names(newkids) <- oldnames
      newtab <- subtree
      tree_children(newtab) <- newkids
      if (length(backpath) > 0) {
        ret <- recursive_replace(tt, backpath, value = newtab)
      } else {
        ret <- newtab
      }
      return(ret)
    } else if (!(curname %in% names(oldkids))) {
      stop(
        "Unable to find child(ren) '",
        curname, "'\n\t occurred at path: ",
        paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
        "\n  Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
        "'table_structure(obj)' to explore valid paths."
      )
    }
    subtree <- tree_children(subtree)[[curname]]
    backpath <- c(backpath, curpath[1])
    curpath <- curpath[-1]
    count <- count + 1
  }
  real_backpath <- path[seq_len(count)]

  na.pos <- match.arg(na.pos)
  ##    subtree <- tt_at_path(tt, path)
  kids <- tree_children(subtree)
  ## relax this to allow character "scores"
  ## scores <- vapply(kids, scorefun, NA_real_)
  scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e))
  errs <- which(vapply(scores, is, class2 = "error", TRUE))
  if (length(errs) > 0) {
    stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
      "First error: ", scores[[errs[1]]]$message,
      "\n\toccurred at path: ",
      paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "),
      call. = FALSE
    )
  } else {
    scores <- unlist(scores)
  }
  if (!is.null(dim(scores)) || length(scores) != length(kids)) {
    stop(
      "Score function does not appear to have return exactly one ",
      "scalar value per child"
    )
  }
  if (is.na(decreasing)) {
    decreasing <- if (is.character(scores)) FALSE else TRUE
  }
  ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing)
  newkids <- kids[ord]
  if (anyNA(scores) && na.pos == "omit") { # we did na last here
    newkids <- head(newkids, -1 * sum(is.na(scores)))
  }

  newtree <- subtree
  tree_children(newtree) <- newkids
  tt_at_path(tt, path) <- newtree
  tt
}

#' Variable associated with a split
#'
#' This function is intended for use when writing custom splitting logic. In cases where the split is associated with
#' a single variable, the name of that variable will be returned. At time of writing this includes splits generated
#' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()],
#' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives.
#'
#' @param spl (`VarLevelSplit`)\cr the split object.
#'
#' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised.
#'
#' @export
#' @seealso \code{\link{make_split_fun}}
setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))

#' @rdname spl_variable
#' @export
setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))

#' @rdname spl_variable
#' @export
setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))

#' @rdname spl_variable
#' @export
setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))

#' @rdname spl_variable
#' @export
setMethod(
  "spl_variable", "Split",
  function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
)

in_col_split <- function(spl_ctx) {
  identical(
    names(spl_ctx),
    names(context_df_row(cinfo = NULL))
  )
}

assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
  msg_2_append <- ""
  if (!is.null(component)) {
    msg_2_append <- paste0(
      "Invalid split function constructed by upstream call to ",
      "make_split_fun. Problem source: ",
      component, " argument."
    )
  }
  if (!(nm %in% names(pinfo))) {
    stop(
      "Split result does not have required element: ", nm, ".",
      msg_2_append
    )
  }
  if (!is.null(len) && length(pinfo[[nm]]) != len) {
    stop(
      "Split result element ", nm, " does not have required length ", len, ".",
      msg_2_append
    )
  }
  TRUE
}

validate_split_result <- function(pinfo, component = NULL) {
  assert_splres_element(pinfo, "datasplit", component = component)
  len <- length(pinfo$datasplit)
  assert_splres_element(pinfo, "values", len, component = component)
  assert_splres_element(pinfo, "labels", len, component = component)
  TRUE
}

#' Construct split result object
#'
#' These functions can be used to create or add to a split result in functions which implement core splitting or
#' post-processing within a custom split function.
#'
#' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet.
#' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split.
#' @param labels (`character`)\cr the labels associated with each facet.
#' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to
#'   analysis functions applied within the facet.
#' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,
#'     created with `quote()`) to be used during column subsetting.
#'
#' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and
#'   `labels`, which are the same length and correspond to each other element-wise.
#'
#' @details
#' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables
#' internals expect it, most of which are not relevant to end users.
#'
#' @examples
#' splres <- make_split_result(
#'   values = c("hi", "lo"),
#'   datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),
#'   labels = c("more data", "less data"),
#'   subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))
#' )
#'
#' splres2 <- add_to_split_result(splres,
#'   values = "med",
#'   datasplit = list(med = mtcars[1:20, ]),
#'   labels = "kinda some data",
#'   subset_exprs = quote(seq_along(wt) <= 20)
#' )
#'
#' @family make_custom_split
#' @rdname make_split_result
#' @export
#' @family make_custom_split
make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
  if (length(values) == 1 && is(datasplit, "data.frame")) {
    datasplit <- list(datasplit)
  }
  ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)
  if (!is.null(extras)) {
    ret$extras <- extras
  }
  .fixupvals(ret)
}

#' @param splres (`list`)\cr a list representing the result of splitting.
#'
#' @rdname make_split_result
#' @export
add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
  validate_split_result(splres)
  newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))
  ret <- lapply(
    names(splres),
    function(nm) c(splres[[nm]], newstuff[[nm]])
  )
  names(ret) <- names(splres)
  .fixupvals(ret)
}


.can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))

#' Create a custom splitting function
#'
#' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that
#'   should split via `core_split`. They will be called on the data in the order they appear in the list.
#' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that
#'   `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior
#'   cannot be used in column splits.
#' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting.
#'
#' @details
#' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process:
#'
#' 1. Pre-processing of the incoming data to be split.
#' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets.
#' 3. Post-processing operations on the set of facets (groups) generated by the split.
#'
#' This function provides an interface to create custom split functions by implementing and specifying sets of
#' operations in each of those classes of customization independently.
#'
#' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept
#' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame.
#' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if
#' necessary (though we note that these  new columns cannot be used in the layout as split or analysis variables,
#' because they will not be present when validity checking is done).
#'
#' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones
#' or to reorder levels based on observed counts, etc.
#'
#' Core  splitting functions  override  the  fundamental
#' splitting procedure,  and are only  necessary in rare  cases. These
#' must  accept  `spl`, `df`,  `vals`,  `labels`,  and can  optionally
#' accept `.spl_context`. They should return a split result object
#' constructed via `make_split_result()`.
#'
#' In particular, if the custom split function will be used in
#' column space, subsetting expressions (e.g., as returned by
#' `quote()` or `bquote` must be provided, while they are
#' optional (and largely ignored, currently) in row space.
#'
#'
#' Post-processing functions (3) must accept the result of the core split as their first argument (which can be
#' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a
#' modified version of the same structure specified above for core splitting.
#'
#' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied
#' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively).
#'
#' @return A custom function that can be used as a split function.
#'
#' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do.
#'
#' @examples
#' mysplitfun <- make_split_fun(
#'   pre = list(drop_facet_levels),
#'   post = list(add_overall_facet("ALL", "All Arms"))
#' )
#'
#' basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = mysplitfun) %>%
#'   analyze("AGE") %>%
#'   build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
#'
#' ## post (and pre) arguments can take multiple functions, here
#' ## we add an overall facet and the reorder the facets
#' reorder_facets <- function(splret, spl, fulldf, ...) {
#'   ord <- order(names(splret$values))
#'   make_split_result(
#'     splret$values[ord],
#'     splret$datasplit[ord],
#'     splret$labels[ord]
#'   )
#' }
#'
#' mysplitfun2 <- make_split_fun(
#'   pre = list(drop_facet_levels),
#'   post = list(
#'     add_overall_facet("ALL", "All Arms"),
#'     reorder_facets
#'   )
#' )
#' basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = mysplitfun2) %>%
#'   analyze("AGE") %>%
#'   build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
#'
#' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
#'   make_split_result(c("stupid", "silly"),
#'     datasplit = list(df[1:10, ], df[11:30, ]),
#'     labels = c("first 10", "second 20")
#'   )
#' }
#'
#' dumb_30_facet <- add_combo_facet("dumb",
#'   label = "thirty patients",
#'   levels = c("stupid", "silly")
#' )
#' nonsense_splfun <- make_split_fun(
#'   core_split = very_stupid_core,
#'   post = list(dumb_30_facet)
#' )
#'
#' ## recall core split overriding is not supported in column space
#' ## currently, but we can see it in action in row space
#'
#' lyt_silly <- basic_table() %>%
#'   split_rows_by("ARM", split_fun = nonsense_splfun) %>%
#'   summarize_row_groups() %>%
#'   analyze("AGE")
#' silly_table <- build_table(lyt_silly, DM)
#' silly_table
#'
#' @family make_custom_split
#' @export
make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
  function(df,
           spl,
           vals = NULL,
           labels = NULL,
           trim = FALSE,
           .spl_context) {
    orig_columns <- names(df)
    for (pre_fn in pre) {
      if (.can_take_spl_context(pre_fn)) {
        df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context)
      } else {
        df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels)
      }
      if (!is(df, "data.frame")) {
        stop(
          "Error in custom split function, pre-split step did not return a data.frame. ",
          "See upstream call to make_split_fun for original source of error."
        )
      }
    }

    if (!all(orig_columns %in% names(df))) {
      stop(
        "Preprocessing functions(s) in custom split function removed a column from the incoming data.",
        " This is not supported. See upstread make_split_fun call (pre argument) for original source of error."
      )
    }

    if (is.null(core_split)) {
      ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)
    } else {
      ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)
      validate_split_result(ret, component = "core_split")
    }

    for (post_fn in post) {
      if (.can_take_spl_context(post_fn)) {
        ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df)
      } else {
        ret <- post_fn(ret, spl = spl, fulldf = df)
      }
    }
    validate_split_result(ret, "post")
    ret
  }
}

#' Add a combination facet in post-processing
#'
#' Add a combination facet during the post-processing stage in a custom split fun.
#'
#' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.).
#' @param label (`string`)\cr label for the resulting facet.
#' @param levels (`character`)\cr vector of levels to combine within the resulting facet.
#' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet.
#'
#' @details
#' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for
#' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data
#' that appears in both will be duplicated.
#'
#' @return A function which can be used within the `post` argument in [make_split_fun()].
#'
#' @seealso [make_split_fun()]
#'
#' @examples
#' mysplfun <- make_split_fun(post = list(
#'   add_combo_facet("A_B",
#'     label = "Arms A+B",
#'     levels = c("A: Drug X", "B: Placebo")
#'   ),
#'   add_overall_facet("ALL", label = "All Arms")
#' ))
#'
#' lyt <- basic_table(show_colcounts = TRUE) %>%
#'   split_cols_by("ARM", split_fun = mysplfun) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' @family make_custom_split
#' @export
add_combo_facet <- function(name, label = name, levels, extra = list()) {
  function(ret, spl, .spl_context, fulldf) {
    if (is(levels, "AllLevelsSentinel")) {
      subexpr <- expression(TRUE)
      datpart <- list(fulldf)
    } else {
      subexpr <- .combine_value_exprs(ret$values[levels])
      datpart <- list(do.call(rbind, ret$datasplit[levels]))
    }


    val <- LevelComboSplitValue(
      val = name, extr = extra, combolevels = levels, label = label,
      sub_expr = subexpr
    )
    add_to_split_result(ret,
      values = list(val), labels = label,
      datasplit = datpart
    )
  }
}

.combine_value_exprs <- function(val_lst, spl) {
  exprs <- lapply(val_lst, value_expr)
  nulls <- vapply(exprs, is.null, TRUE)
  if (all(nulls)) {
    return(NULL) # default behavior all the way down the line, no need to do anything.
  } else if (any(nulls)) {
    exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))
  }
  Reduce(.or_combine_exprs, exprs)
}

## no NULLS coming in here, everything has been populated
## by either custom subsetting expressions or the result of make_subset_expr(spl, val)
.or_combine_exprs <- function(ex1, ex2) {
  if (identical(ex1, expression(FALSE))) {
    return(ex2)
  } else if (identical(ex2, expression(FALSE))) {
    return(ex1)
  } else if (identical(ex1, expression(TRUE)) || identical(ex2, expression(TRUE))) {
    return(TRUE)
  }
  as.expression(bquote((.(a)) | .(b), list(a = ex1[[1]], b = ex2[[1]])))
}

#' @rdname add_combo_facet
#' @export
add_overall_facet <- function(name, label, extra = list()) {
  add_combo_facet(
    name = name, label = label, levels = select_all_levels,
    extra = extra
  )
}

#' Trim levels of another variable from each facet (post-processing split step)
#'
#' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet.
#'
#' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`.
#'
#' @seealso [make_split_fun()]
#'
#' @family make_custom_split
#' @export
trim_levels_in_facets <- function(innervar) {
  function(ret, ...) {
    for (var in innervar) {
      ret$datasplit <- lapply(ret$datasplit, function(df) {
        df[[var]] <- factor(df[[var]])
        df
      })
    }
    ret
  }
}

#' Pre-processing function for use in `make_split_fun`
#'
#' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called
#' directly by end users.
#'
#' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet.
#' @param spl (`VarLevelSplit`)\cr the split.
#' @param ... additional parameters passed internally.
#'
#' @seealso [make_split_fun()]
#'
#' @family make_custom_split
#' @export
drop_facet_levels <- function(df, spl, ...) {
  if (!is(spl, "VarLevelSplit") || is.na(spl_payload(spl))) {
    stop("Unable to determine faceting variable in drop_facet_levels application.")
  }
  var <- spl_payload(spl)
  df[[var]] <- factor(df[[var]])
  df
}

treestruct <- function(obj, ind = 0L) {
  nc <- ncol(obj)
  cat(rep(" ", times = ind),
    sprintf("[%s] %s", class(obj), obj_name(obj)),
    sep = ""
  )
  if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
    crows <- nrow(content_table(obj))
    ccols <- if (crows == 0) 0 else nc
    cat(sprintf(
      " [cont: %d x %d]",
      crows, ccols
    ))
  }
  if (is(obj, "VTableTree") && length(tree_children(obj))) {
    kids <- tree_children(obj)
    if (are(kids, "TableRow")) {
      cat(sprintf(
        " (%d x %d)\n",
        length(kids), nc
      ))
    } else {
      cat("\n")
      lapply(kids, treestruct, ind = ind + 1)
    }
  }
  invisible(NULL)
}

setGeneric(
  "ploads_to_str",
  function(x, collapse = ":") standardGeneric("ploads_to_str")
)

setMethod(
  "ploads_to_str", "Split",
  function(x, collapse = ":") {
    paste(sapply(spl_payload(x), ploads_to_str),
      collapse = collapse
    )
  }
)

setMethod(
  "ploads_to_str", "CompoundSplit",
  function(x, collapse = ":") {
    paste(sapply(spl_payload(x), ploads_to_str),
      collapse = collapse
    )
  }
)

setMethod(
  "ploads_to_str", "list",
  function(x, collapse = ":") {
    stop("Please contact the maintainer")
  }
)

setMethod(
  "ploads_to_str", "SplitVector",
  function(x, collapse = ":") {
    sapply(x, ploads_to_str)
  }
)

setMethod(
  "ploads_to_str", "ANY",
  function(x, collapse = ":") {
    paste(x)
  }
)

setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))

setMethod(
  "payloadmsg", "VarLevelSplit",
  function(spl) {
    spl_payload(spl)
  }
)

setMethod(
  "payloadmsg", "MultiVarSplit",
  function(spl) "var"
)

setMethod(
  "payloadmsg", "VarLevWBaselineSplit",
  function(spl) {
    paste0(
      spl_payload(spl), "[bsl ",
      spl@ref_group_value, # XXX XXX
      "]"
    )
  }
)

setMethod(
  "payloadmsg", "ManualSplit",
  function(spl) "mnl"
)

setMethod(
  "payloadmsg", "AllSplit",
  function(spl) "all"
)

setMethod(
  "payloadmsg", "ANY",
  function(spl) {
    warning("don't know how to make payload print message for Split of class", class(spl))
    "XXX"
  }
)

spldesc <- function(spl, value = "") {
  value <- rawvalues(value)
  payloadmsg <- payloadmsg(spl)
  format <- "%s (%s)"
  sprintf(
    format,
    value,
    payloadmsg
  )
}

layoutmsg <- function(obj) {
  ## if(!is(obj, "VLayoutNode"))
  ##     stop("how did a non layoutnode object get in docatlayout??")

  pos <- tree_pos(obj)
  spllst <- pos_splits(pos)
  spvallst <- pos_splvals(pos)
  if (is(obj, "LayoutAxisTree")) {
    kids <- tree_children(obj)
    return(unlist(lapply(kids, layoutmsg)))
  }

  msg <- paste(
    collapse = " -> ",
    mapply(spldesc,
      spl = spllst,
      value = spvallst
    )
  )
  msg
}

setMethod(
  "show", "LayoutAxisTree",
  function(object) {
    msg <- layoutmsg(object)
    cat(msg, "\n")
    invisible(object)
  }
)


#' Display column tree structure
#'
#' Displays the tree structure of the columns of a
#' table or column structure object.
#'
#' @inheritParams gen_args
#'
#' @return Nothing, called for its side effect of displaying
#' a summary to the terminal.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_cols_by("STRATA1") %>%
#'   split_cols_by("SEX", nested = FALSE) %>%
#'   analyze("AGE")
#'
#' tbl <- build_table(lyt, ex_adsl)
#' coltree_structure(tbl)
#' @export
coltree_structure <- function(obj) {
  ctree <- coltree(obj)
  cat(layoutmsg2(ctree))
}

lastposmsg <- function(pos) {
  spls <- pos_splits(pos)
  splvals <- value_names(pos_splvals(pos))
  indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "),
    spl = spls,
    valnm = splvals,
    SIMPLIFY = FALSE
  ))
  paste(indiv_msgs, collapse = " -> ")
}

layoutmsg2 <- function(obj, level = 1) {
  nm <- obj_name(obj)
  pos <- tree_pos(obj)
  nopos <- identical(pos, EmptyTreePos)

  msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
  if (is(obj, "LayoutAxisTree")) {
    kids <- tree_children(obj)
    msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1)))
  }
  msg
}

setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))

setMethod(
  "spltype_abbrev", "VarLevelSplit",
  function(obj) "lvls"
)

setMethod(
  "spltype_abbrev", "VarLevWBaselineSplit",
  function(obj) paste("ref_group", obj@ref_group_value)
)

setMethod(
  "spltype_abbrev", "MultiVarSplit",
  function(obj) "vars"
)

setMethod(
  "spltype_abbrev", "VarStaticCutSplit",
  function(obj) "scut"
)

setMethod(
  "spltype_abbrev", "VarDynCutSplit",
  function(obj) "dcut"
)
setMethod(
  "spltype_abbrev", "AllSplit",
  function(obj) "all obs"
)
## setMethod("spltype_abbrev", "NULLSplit",
##           function(obj) "no obs")

setMethod(
  "spltype_abbrev", "AnalyzeVarSplit",
  function(obj) "** analysis **"
)

setMethod(
  "spltype_abbrev", "CompoundSplit",
  function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
)

setMethod(
  "spltype_abbrev", "AnalyzeMultiVars",
  function(obj) "** multivar analysis **"
)
setMethod(
  "spltype_abbrev", "AnalyzeColVarSplit",
  function(obj) "** col-var analysis **"
)

docat_splitvec <- function(object, indent = 0) {
  if (indent > 0) {
    cat(rep(" ", times = indent), sep = "")
  }
  if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
    tab <- object[[1]]
    msg <- sprintf(
      "A Pre-Existing Table [%d x %d]",
      nrow(tab), ncol(tab)
    )
  } else {
    plds <- ploads_to_str(object) ## lapply(object, spl_payload))

    tabbrev <- sapply(object, spltype_abbrev)
    msg <- paste(
      collapse = " -> ",
      paste0(plds, " (", tabbrev, ")")
    )
  }
  cat(msg, "\n")
}

setMethod(
  "show", "SplitVector",
  function(object) {
    cat("A SplitVector Pre-defining a Tree Structure\n\n")
    docat_splitvec(object)
    cat("\n")
    invisible(object)
  }
)

docat_predataxis <- function(object, indent = 0) {
  lapply(object, docat_splitvec)
}

setMethod(
  "show", "PreDataColLayout",
  function(object) {
    cat("A Pre-data Column Layout Object\n\n")
    docat_predataxis(object)
    invisible(object)
  }
)

setMethod(
  "show", "PreDataRowLayout",
  function(object) {
    cat("A Pre-data Row Layout Object\n\n")
    docat_predataxis(object)
    invisible(object)
  }
)

setMethod(
  "show", "PreDataTableLayouts",
  function(object) {
    cat("A Pre-data Table Layout\n")
    cat("\nColumn-Split Structure:\n")
    docat_predataxis(object@col_layout)
    cat("\nRow-Split Structure:\n")
    docat_predataxis(object@row_layout)
    cat("\n")
    invisible(object)
  }
)

setMethod(
  "show", "InstantiatedColumnInfo",
  function(object) {
    layoutmsg <- layoutmsg(coltree(object))
    cat("An InstantiatedColumnInfo object",
      "Columns:",
      layoutmsg,
      if (disp_ccounts(object)) {
        paste(
          "ColumnCounts:\n",
          paste(col_counts(object),
            collapse = ", "
          )
        )
      },
      "",
      sep = "\n"
    )
    invisible(object)
  }
)

#' @rdname int_methods
setMethod("print", "VTableTree", function(x, ...) {
  msg <- toString(x, ...)
  cat(msg)
  invisible(x)
})

#' @rdname int_methods
setMethod("show", "VTableTree", function(object) {
  cat(toString(object))
  invisible(object)
})

setMethod("show", "TableRow", function(object) {
  cat(sprintf(
    "[%s indent_mod %d]: %s   %s\n",
    class(object),
    indent_mod(object),
    obj_label(object),
    paste(as.vector(get_formatted_cells(object)),
      collapse = "   "
    )
  ))
  invisible(object)
})

## NB handling the case where there are no values is done during tabulation
## which is the only reason expression(TRUE) is ok, because otherwise
## we (sometimes) run into
## factor()[TRUE] giving <NA> (i.e. length 1)
setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))

setMethod(
  "make_subset_expr", "VarLevelSplit",
  function(spl, val) {
    ## this is how custom split functions will communicate the correct expression
    ## to the column modeling code
    if (length(value_expr(val)) > 0) {
      return(value_expr(val))
    }

    v <- unlist(rawvalues(val))
    ## XXX if we're including all levels should even missing be included?
    if (is(v, "AllLevelsSentinel")) {
      as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl)))))
    } else {
      as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(
        a = as.name(spl_payload(spl)),
        b = v
      )))
    }
  }
)

setMethod(
  "make_subset_expr", "MultiVarSplit",
  function(spl, val) {
    ## this is how custom split functions will communicate the correct expression
    ## to the column modeling code
    if (length(value_expr(val)) > 0) {
      return(value_expr(val))
    }

    ## v = rawvalues(val)
    ## as.expression(bquote(!is.na(.(a)), list(a = v)))
    expression(TRUE)
  }
)

setMethod(
  "make_subset_expr", "AnalyzeVarSplit",
  function(spl, val) {
    if (avar_inclNAs(spl)) {
      expression(TRUE)
    } else {
      as.expression(bquote(
        !is.na(.(a)),
        list(a = as.name(spl_payload(spl)))
      ))
    }
  }
)

setMethod(
  "make_subset_expr", "AnalyzeColVarSplit",
  function(spl, val) {
    expression(TRUE)
  }
)

## XXX these are going to be ridiculously slow
## FIXME

setMethod(
  "make_subset_expr", "VarStaticCutSplit",
  function(spl, val) {
    v <- rawvalues(val)
    ##    as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels),
    as.expression(bquote(
      cut(.(a),
        breaks = .(brk), labels = .(labels),
        include.lowest = TRUE
      ) == .(b),
      list(
        a = as.name(spl_payload(spl)),
        b = v,
        brk = spl_cuts(spl),
        labels = spl_cutlabels(spl)
      )
    ))
  }
)

## NB this assumes spl_cutlabels(spl) is in order!!!!!!
setMethod(
  "make_subset_expr", "CumulativeCutSplit",
  function(spl, val) {
    v <- rawvalues(val)
    ## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk),
    as.expression(bquote(
      as.integer(cut(.(a),
        breaks = .(brk),
        labels = .(labels),
        include.lowest = TRUE
      )) <=
        as.integer(factor(.(b), levels = .(labels))),
      list(
        a = as.name(spl_payload(spl)),
        b = v,
        brk = spl_cuts(spl),
        labels = spl_cutlabels(spl)
      )
    ))
  }
)

## I think this one is unnecessary,
## build_table collapses DynCutSplits into
## static ones.
##
## XXX TODO fixme
## setMethod("make_subset_expr", "VarDynCutSplit",
##           function(spl, val) {
##     v = rawvalues(val)
##     ##   as.expression(bquote(which(.(fun)(.(a)) == .(b)),
##     as.expression(bquote(.(fun)(.(a)) == .(b)),
##                   list(a = as.name(spl_payload(spl)),
##                        b = v,
##                        fun = spl@cut_fun))
## })

setMethod(
  "make_subset_expr", "AllSplit",
  function(spl, val) expression(TRUE)
)

## probably don't need this

setMethod(
  "make_subset_expr", "expression",
  function(spl, val) spl
)

setMethod(
  "make_subset_expr", "character",
  function(spl, val) {
    newspl <- VarLevelSplit(spl, spl)
    make_subset_expr(newspl, val)
  }
)

.combine_subset_exprs <- function(ex1, ex2) {
  if (is.null(ex1) || identical(ex1, expression(TRUE))) {
    if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
      return(ex2)
    } else {
      return(expression(TRUE))
    }
  }

  ## if(is.null(ex2))
  ##     ex2 <- expression(TRUE)
  stopifnot(is.expression(ex1), is.expression(ex2))
  as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))
}

make_pos_subset <- function(spls = pos_splits(pos),
                            svals = pos_splvals(pos),
                            pos) {
  expr <- NULL
  for (i in seq_along(spls)) {
    newexpr <- make_subset_expr(spls[[i]], svals[[i]])
    expr <- .combine_subset_exprs(expr, newexpr)
  }
  expr
}

get_pos_extra <- function(svals = pos_splvals(pos),
                          pos) {
  ret <- list()
  for (i in seq_along(svals)) {
    extrs <- splv_extra(svals[[i]])
    if (any(names(ret) %in% names(extrs))) {
      stop("same extra argument specified at multiple levels of nesting. Not currently supported")
    }
    ret <- c(ret, extrs)
  }
  ret
}

get_col_extras <- function(ctree) {
  leaves <- collect_leaves(ctree)
  lapply(
    leaves,
    function(x) get_pos_extra(pos = tree_pos(x))
  )
}

setGeneric(
  "make_col_subsets",
  function(lyt, df) standardGeneric("make_col_subsets")
)

setMethod(
  "make_col_subsets", "LayoutColTree",
  function(lyt, df) {
    leaves <- collect_leaves(lyt)
    lapply(leaves, make_col_subsets)
  }
)

setMethod(
  "make_col_subsets", "LayoutColLeaf",
  function(lyt, df) {
    make_pos_subset(pos = tree_pos(lyt))
  }
)

create_colinfo <- function(lyt, df, rtpos = TreePos(),
                           counts = NULL,
                           alt_counts_df = NULL,
                           total = NULL,
                           topleft = NULL) {
  ## this will work whether clayout is pre or post
  ## data
  clayout <- clayout(lyt)
  if (is.null(topleft)) {
    topleft <- top_left(lyt)
  }
  cc_format <- colcount_format(lyt) %||% "(N=xx)"

  ## do it this way for full backwards compatibility
  if (is.null(alt_counts_df)) {
    alt_counts_df <- df
  }
  ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format)
  if (!is.na(disp_ccounts(lyt))) {
    leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path
    for (path in leaf_pths) {
      colcount_visible(ctree, path) <- disp_ccounts(lyt)
    }
  }

  cexprs <- make_col_subsets(ctree, df)
  colextras <- col_extra_args(ctree)

  ## calculate the counts based on the df
  ## This presumes that it is called on the WHOLE dataset,
  ## NOT after any splitting has occurred. Otherwise
  ## the counts will obviously be wrong.
  if (is.null(counts)) {
    counts <- rep(NA_integer_, length(cexprs))
  } else if (length(counts) != length(cexprs)) {
    stop(
      "Length of overriding counts must equal number of columns. Got ",
      length(counts), " values for ", length(cexprs), " columns. ",
      "Use NAs to specify that the default counting machinery should be ",
      "used for that position."
    )
  }

  counts_df_name <- "alt_counts_df"
  if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
    alt_counts_df <- df
    counts_df_name <- "df"
  }
  calcpos <- is.na(counts)

  calccounts <- sapply(cexprs, function(ex) {
    if (identical(ex, expression(TRUE))) {
      nrow(alt_counts_df)
    } else if (identical(ex, expression(FALSE))) {
      0L
    } else {
      vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)
      if (is(vec, "numeric")) {
        length(vec)
      } else if (is(vec, "logical")) { ## sum(is.na(.)) ????
        sum(vec, na.rm = TRUE)
      }
    }
  })
  counts[calcpos] <- calccounts[calcpos]
  counts <- as.integer(counts)
  if (is.null(total)) {
    total <- sum(counts)
  }

  cpths <- col_paths(ctree)
  for (i in seq_along(cpths)) {
    facet_colcount(ctree, cpths[[i]]) <- counts[i]
  }
  InstantiatedColumnInfo(
    treelyt = ctree,
    csubs = cexprs,
    extras = colextras,
    cnts = counts,
    dispcounts = disp_ccounts(lyt),
    countformat = cc_format,
    total_cnt = total,
    topleft = topleft
  )
}

#' Compare two rtables
#'
#' Prints a matrix where `.` means cell matches, `X` means cell does
#' not match, `+` cell (row) is missing, and `-` cell (row)
#' should not be there. If `structure` is set to `TRUE`, `C` indicates
#' column-structure mismatch, `R` indicates row-structure mismatch, and
#' `S` indicates mismatch in both row and column structure.
#'
#' @param object (`VTableTree`)\cr `rtable` to test.
#' @param expected (`VTableTree`)\cr expected `rtable`.
#' @param tol (`numeric(1)`)\cr tolerance.
#' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are
#'   silently ignored.
#' @param structure (`flag`)\cr whether structures (in the form of column and row
#'   paths to cells) should be compared. Currently defaults to `FALSE`, but this is
#'   subject to change in future versions.
#'
#' @note In its current form, `compare_rtables` does not take structure into
#'   account, only row and cell position.
#'
#' @return A matrix of class `rtables_diff` representing the differences
#'  between `object` and `expected` as described above.
#'
#' @examples
#' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
#' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
#'
#' compare_rtables(object = t1, expected = t2)
#'
#' if (interactive()) {
#'   Viewer(t1, t2)
#' }
#'
#' expected <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' expected
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' compare_rtables(object, expected, comp.attr = FALSE)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title")
#' )
#'
#' compare_rtables(object, expected)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 14, 15.03),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
#' )
#'
#' compare_rtables(object, expected)
#'
#' object <- rtable(
#'   header = c("ARM A\nN=100", "ARM B\nN=200"),
#'   format = "xx",
#'   rrow("row 1", 10, 15),
#'   rrow(),
#'   rrow("section title"),
#'   rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
#' )
#'
#' compare_rtables(object, expected)
#'
#' @export
compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,
                            structure = FALSE) {
  # if (identical(object, expected)) return(invisible(TRUE))

  if (!is(object, "VTableTree")) {
    stop(
      "argument object is expected to be of class TableTree or ",
      "ElementaryTable"
    )
  }
  if (!is(expected, "VTableTree")) {
    stop(
      "argument expected is expected to be of class TableTree or ",
      "ElementaryTable"
    )
  }
  dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)

  X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
  row.names(X) <- as.character(1:dim_out[1])
  colnames(X) <- as.character(1:dim_out[2])

  if (!identical(names(object), names(expected))) {
    attr(X, "info") <- "column names are not the same"
  }

  if (!comp.attr) {
    attr(X, "info") <- c(
      attr(X, "info"),
      "cell attributes have not been compared"
    )
  }
  if (!identical(row.names(object), row.names(expected))) {
    attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")
  }

  nro <- nrow(object)
  nre <- nrow(expected)
  nco <- ncol(object)
  nce <- ncol(expected)

  if (nco < nce) {
    X[, seq(nco + 1, nce)] <- "-"
  } else if (nce < nco) {
    X[, seq(nce + 1, nco)] <- "+"
  }
  if (nro < nre) {
    X[seq(nro + 1, nre), ] <- "-"
  } else if (nre < nro) {
    X[seq(nre + 1, nro), ] <- "+"
  }

  orig_object <- object # nolint
  orig_expected <- expected # nolint
  if (nro != nre || nco != nce) {
    object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
    expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
    inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)
    X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner
    class(X) <- c("rtables_diff", class(X))
    return(X)
  }

  ## from here dimensions match!

  orows <- cell_values(object, omit_labrows = FALSE)
  erows <- cell_values(expected, omit_labrows = FALSE)
  if (nrow(object) == 1) {
    orows <- list(orows)
    erows <- list(erows)
  }
  res <- mapply(compare_rrows,
    row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),
    USE.NAMES = FALSE, SIMPLIFY = FALSE
  )
  X <- do.call(rbind, res)
  rpo <- row_paths(object)
  rpe <- row_paths(expected)

  if (comp.attr) {
    ofmts <- value_formats(object)
    efmts <- value_formats(expected)
    ## dim(ofmts) <- NULL
    ## dim(efmts) <- NULL

    fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim


    ## note the single index here!!!, no comma!!!!
    X[fmt_mismatch] <- "X"
  }


  if (structure) {
    rp_mismatches <- !mapply(identical, x = rpo, y = rpe)
    cpo <- col_paths(object)
    cpe <- col_paths(expected)
    cp_mismatches <- !mapply(identical, x = cpo, y = cpe)

    if (any(rp_mismatches)) { # P for (row or column) path do not match
      X[rp_mismatches, ] <- "R"
    }
    if (any(cp_mismatches)) {
      crep <- rep("C", nrow(X))
      if (any(rp_mismatches)) {
        crep[rp_mismatches] <- "P"
      }
      X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))
    }
  }
  class(X) <- c("rtables_diff", class(X))
  X
}

## for (i in 1:dim(X)[1]) {
##   for (j in 1:dim(X)[2]) {

##     is_equivalent <- TRUE
##     if (i <= nro && i <= nre && j <= nco && j <= nce) {
##       x <- object[i,j, drop = TRUE]
##       y <- expected[i,j, drop = TRUE]

##       attr_x <- attributes(x)
##       attr_y <- attributes(y)

##       attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]
##       attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]

##       if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
##         is_equivalent <- FALSE
##       } else if (is.numeric(x) && is.numeric(y)) {
##         if (any(abs(na.omit(x - y)) > tol)) {
##           is_equivalent <- FALSE
##         }
##       } else {
##         if (!identical(x, y)) {
##           is_equivalent <- FALSE
##         }
##       }

##       if (!is_equivalent) {
##         X[i,j] <- "X"
##       }
##     } else if (i > nro || j > nco) {
##       ## missing in object
##       X[i, j] <- "+"
##     } else {
##       ## too many elements
##       X[i, j] <- "-"
##     }
##   }
## }
## class(X) <- c("rtable_diff", class(X))
## X
## }

compare_value <- function(x, y, tol) {
  if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
    "."
  } else {
    "X"
  }
}

compare_rrows <- function(row1, row2, tol, ncol) {
  if (length(row1) == ncol && length(row2) == ncol) {
    mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)
  } else if (length(row1) == 0 && length(row2) == 0) {
    rep(".", ncol)
  } else {
    rep("X", ncol)
  }
}

## #' @export
## print.rtable_diff <- function(x, ...) {
##   print.default(unclass(x), quote = FALSE, ...)
## }

.reindex_one_pos <- function(refs, cur_idx_fun) {
  if (length(refs) == 0) {
    return(refs)
  }

  lapply(refs, function(refi) {
    ## these can be symbols, e.g. ^, † now, those are
    ## special and don't get reindexed cause they're not numbered
    ## to begin with
    idx <- ref_index(refi)
    if (is.na(idx) || !is.na(as.integer(idx))) {
      ref_index(refi) <- cur_idx_fun(refi)
    }
    refi
  })
}

setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper"))

setMethod(
  ".idx_helper", "TableRow",
  function(tr, cur_idx_fun) {
    row_footnotes(tr) <- .reindex_one_pos(
      row_footnotes(tr),
      cur_idx_fun
    )

    cell_footnotes(tr) <- lapply(cell_footnotes(tr), ## crfs,
      .reindex_one_pos,
      cur_idx_fun = cur_idx_fun
    )
    tr
  }
)

setMethod(
  ".idx_helper", "VTableTree",
  function(tr, cur_idx_fun) {
    if (!labelrow_visible(tr)) {
      stop("got a row footnote on a non-visible label row. this should never happen") # nocov
    }
    lr <- tt_labelrow(tr)

    row_footnotes(lr) <- .reindex_one_pos(
      row_footnotes(lr),
      cur_idx_fun
    )

    tt_labelrow(tr) <- lr

    tr
  }
)

index_col_refs <- function(tt, cur_idx_fun) {
  ctree <- coltree(tt)
  ctree <- .index_col_refs_inner(ctree, cur_idx_fun)
  coltree(tt) <- ctree
  tt
}

.index_col_refs_inner <- function(ctree, cur_idx_fun) {
  col_footnotes(ctree) <- .reindex_one_pos(
    col_footnotes(ctree),
    cur_idx_fun
  )

  if (is(ctree, "LayoutColTree")) {
    tree_children(ctree) <- lapply(tree_children(ctree),
      .index_col_refs_inner,
      cur_idx_fun = cur_idx_fun
    )
  }
  ctree
  ## cfs <- col_footnotes(ctree)
  ## if(length(unlist(cfs)) > 0) {
  ##     col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs,
  ##                                      function(refs) lapply(refs, function(refi) {
}

#' Update footnote indices on a built table
#'
#' Re-indexes footnotes within a built table.
#'
#' @inheritParams gen_args
#'
#' @details
#' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes
#' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based
#' on the full table.
#'
#' @note In the future this should not generally need to be called manually.
#'
#' @export
update_ref_indexing <- function(tt) {
  col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt))
  row_fnotes <- row_footnotes(tt)
  cell_fnotes <- cell_footnotes(tt)
  all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))
  all_fns <- unlist(t(all_fns))
  unique_fnotes <- unique(sapply(all_fns, ref_msg))

  cur_index <- function(ref_fn) {
    match(ref_msg(ref_fn), unique_fnotes)
  }

  if (ncol(tt) > 0) {
    tt <- index_col_refs(tt, cur_index)
  } ## col_info(tt) <- index_col_refs(col_info(tt), cur_index)
  ## TODO when column refs are a thing we will
  ## still need to do those here before returning!!!
  if (nrow(tt) == 0) {
    return(tt)
  }

  rdf <- make_row_df(tt)

  rdf <- rdf[rdf$nreflines > 0, ]
  if (nrow(rdf) == 0) {
    return(tt)
  }

  for (i in seq_len(nrow(rdf))) {
    path <- unname(rdf$path[[i]])
    tt_at_path(tt, path) <-
      .idx_helper(
        tt_at_path(tt, path),
        cur_index
      )
  }
  tt
}

#' Default tabulation
#'
#' This function is used when [analyze()] is invoked.
#'
#' @param x (`vector`)\cr the *already split* data being tabulated for a particular cell/set of cells.
#' @param ... additional parameters to pass on.
#'
#' @details This function has the following behavior given particular types of inputs:
#'   \describe{
#'     \item{numeric}{calls [mean()] on `x`.}
#'     \item{logical}{calls [sum()] on `x`.}
#'     \item{factor}{calls [length()] on `x`.}
#'   }
#'
#' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error.
#'
#' @inherit in_rows return
#'
#' @author Gabriel Becker and Adrian Waddell
#'
#' @examples
#' simple_analysis(1:3)
#' simple_analysis(iris$Species)
#' simple_analysis(iris$Species == "setosa")
#'
#' @rdname rtinner
#' @export
setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "numeric",
  function(x, ...) in_rows("Mean" = rcell(mean(x, ...), format = "xx.xx"))
)

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "logical",
  function(x, ...) in_rows("Count" = rcell(sum(x, ...), format = "xx"))
)

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "factor",
  function(x, ...) in_rows(.list = as.list(table(x)))
)

#' @rdname rtinner
#' @exportMethod simple_analysis
setMethod(
  "simple_analysis", "ANY",
  function(x, ...) {
    stop("No default simple_analysis behavior for class ", class(x), " please specify FUN  explicitly.")
  }
)

#' Check if an object is a valid `rtable`
#'
#' @param x (`ANY`)\cr an object.
#'
#' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise.
#'
#' @examples
#' is_rtable(build_table(basic_table(), iris))
#'
#' @export
is_rtable <- function(x) {
  is(x, "VTableTree")
}

# nocov start
## is each object in a collection from a class
are <- function(object_collection, class2) {
  all(vapply(object_collection, is, logical(1), class2))
}

num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
  stopifnot(is.numeric(x))

  if (length(x) == 1) {
    return(TRUE)
  }

  y <- range(x) / mean(x)
  isTRUE(all.equal(y[1], y[2], tolerance = tol))
}

# copied over from utils.nest which is not open-source
all_true <- function(lst, fcn, ...) {
  all(vapply(lst, fcn, logical(1), ...))
}

is_logical_single <- function(x) {
  !is.null(x) &&
    is.logical(x) &&
    length(x) == 1 &&
    !is.na(x)
}

is_logical_vector_modif <- function(x, min_length = 1) {
  !is.null(x) &&
    is.logical(x) &&
    is.atomic(x) &&
    !anyNA(x) &&
    ifelse(min_length > 0, length(x) >= min_length, TRUE)
}
# nocov end

# Shorthand for functions that take df as first parameter
.takes_df <- function(f) {
  func_takes(f, "df", is_first = TRUE)
}

# Checking if function takes parameters
func_takes <- function(func, params, is_first = FALSE) {
  if (is.list(func)) {
    return(lapply(func, func_takes, params = params, is_first = is_first))
  }
  if (is.null(func) || !is(func, "function")) {
    # safe-net: should this fail instead?
    return(setNames(rep(FALSE, length(params)), params))
  }
  f_params <- formals(func)
  if (!is_first) {
    return(setNames(params %in% names(f_params), params))
  } else {
    if (length(params) > 1L) {
      stop("is_first works only with one parameters.")
    }
    return(!is.null(f_params) && names(f_params)[1] == params)
  }
}

#' Translate spl_context to a path to display in error messages
#'
#' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred.
#'
#' @return A character string containing a description of the row path corresponding to `ctx`.
#'
#' @export
spl_context_to_disp_path <- function(ctx) {
  ## this can happen in the first split in column space, but
  ## should never happen in row space
  if (length(ctx$split) == 0) {
    return("root")
  }
  if (ctx$split[1] == "root" && ctx$value[1] == "root") {
    ctx <- ctx[-1, ]
  }
  ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
    collapse = "->"
  )
  if (length(ret) == 0 || nchar(ret) == 0) {
    ret <- "root"
  }
  ret
}

# Utility function to paste vector of values in a nice way
paste_vec <- function(vec) {
  paste0('c("', paste(vec, collapse = '", "'), '")')
}

# Utility for checking if a package is installed
check_required_packages <- function(pkgs) {
  for (pkgi in pkgs) {
    if (!requireNamespace(pkgi, quietly = TRUE)) {
      stop(
        "This function requires the ", pkgi, " package. ",
        "Please install it if you wish to use it"
      )
    }
  }
}

#' @importFrom utils browseURL
NULL

#' Display an `rtable` object in the Viewer pane in RStudio or in a browser
#'
#' The table will be displayed using bootstrap styling.
#'
#' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package).
#' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`.
#' @param ... arguments passed to [as_html()].
#'
#' @return Not meaningful. Called for the side effect of opening a browser or viewer pane.
#'
#' @examples
#' if (interactive()) {
#'   sl5 <- factor(iris$Sepal.Length > 5,
#'     levels = c(TRUE, FALSE),
#'     labels = c("S.L > 5", "S.L <= 5")
#'   )
#'
#'   df <- cbind(iris, sl5 = sl5)
#'
#'   lyt <- basic_table() %>%
#'     split_cols_by("sl5") %>%
#'     analyze("Sepal.Length")
#'
#'   tbl <- build_table(lyt, df)
#'
#'   Viewer(tbl)
#'   Viewer(tbl, tbl)
#'
#'
#'   tbl2 <- htmltools::tags$div(
#'     class = "table-responsive",
#'     as_html(tbl, class_table = "table")
#'   )
#'
#'   Viewer(tbl, tbl2)
#' }
#' @export
Viewer <- function(x, y = NULL, ...) {
  check_convert <- function(x, name, accept_NULL = FALSE) {
    if (accept_NULL && is.null(x)) {
      NULL
    } else if (is(x, "shiny.tag")) {
      x
    } else if (is(x, "VTableTree")) {
      as_html(x, ...)
    } else {
      stop("object of class rtable or shiny tag excepted for ", name)
    }
  }

  x_tag <- check_convert(x, "x", FALSE)
  y_tag <- check_convert(y, "y", TRUE)

  html_output <- if (is.null(y)) {
    x_tag
  } else {
    tags$div(class = "container-fluid", htmltools::tags$div(
      class = "row",
      tags$div(class = "col-xs-6", x_tag),
      tags$div(class = "col-xs-6", y_tag)
    ))
  }

  sandbox_folder <- file.path(tempdir(), "rtable")

  if (!dir.exists(sandbox_folder)) {
    dir.create(sandbox_folder, recursive = TRUE)
    pbs <- file.path(path.package(package = "rtables"), "bootstrap/")
    file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)
    # list.files(sandbox_folder)
  }

  # get html name
  n_try <- 10000
  for (i in seq_len(n_try)) {
    htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))

    if (!file.exists(htmlFile)) {
      break
    } else if (i == n_try) {
      stop("too many html rtables created, restart your session")
    }
  }

  html_bs <- tags$html(
    lang = "en",
    tags$head(
      tags$meta(charset = "utf-8"),
      tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
      tags$meta(
        name = "viewport",
        content = "width=device-width, initial-scale=1"
      ),
      tags$title("rtable"),
      tags$link(
        href = "css/bootstrap.min.css",
        rel = "stylesheet"
      )
    ),
    tags$body(
      html_output
    )
  )

  cat(
    paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
    file = htmlFile, append = FALSE
  )

  viewer <- getOption("viewer")

  if (!is.null(viewer)) {
    viewer(htmlFile)
  } else {
    browseURL(htmlFile)
  }
}

#' Create an `ElementaryTable` from a `data.frame`
#'
#' @param df (`data.frame`)\cr a data frame.
#'
#' @details
#' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column
#' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior
#' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique.
#'
#' @seealso [as_result_df()] for the inverse operation.
#'
#' @examples
#' df_to_tt(mtcars)
#'
#' @export
df_to_tt <- function(df) {
  colnms <- colnames(df)
  cinfo <- manual_cols(colnms)
  rnames <- rownames(df)
  havern <- !is.null(rnames)

  if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
    rnames <- df$label_name
    df <- df[, -match("label_name", colnms)]
    colnms <- colnames(df)
    cinfo <- manual_cols(colnms)
    havern <- TRUE
  }

  kids <- lapply(seq_len(nrow(df)), function(i) {
    rni <- if (havern) rnames[i] else ""
    do.call(rrow, c(list(row.name = rni), unclass(df[i, ])))
  })

  ElementaryTable(kids = kids, cinfo = cinfo)
}

#' @importFrom tools file_ext
NULL

#' Create enriched flat value table with paths
#'
#' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then
#' writes that data frame out as a `tsv` file.
#'
#' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are
#' collapsed to character vectors by collapsing the list element with `"|"`.
#'
#' @note
#' There is currently no round-trip capability for this type of export. You can read values exported this way back in
#' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`.
#'
#' @inheritParams gen_args
#' @inheritParams data.frame_export
#' @param file (`string`)\cr the path of the file to written to or read from.
#' @param sep (`string`)\cr defaults to `\t`. See [utils::write.table()] for more details.
#' @param ... (`any`)\cr additional arguments to be passed to [utils::write.table()].
#'
#' @return
#' * `export_as_tsv` returns `NULL` silently.
#' * `import_from_tsv` returns a `data.frame` with re-constituted list values.
#'
#' @seealso [path_enriched_df()] for the underlying function that does the work.
#'
#' @importFrom utils write.table read.table
#' @rdname tsv_io
#' @export
export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path,
                          value_fun = collapse_values, sep = "\t", ...) {
  df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun)
  write.table(df, file, sep = sep, ...)
}

#' @rdname tsv_io
#' @export
import_from_tsv <- function(file) {
  rawdf <- read.table(file, header = TRUE, sep = "\t")
  as.data.frame(lapply(
    rawdf,
    function(col) {
      if (!any(grepl(.collapse_char, col, fixed = TRUE))) {
        col
      } else {
        I(strsplit(col, split = .collapse_char_esc))
      }
    }
  ))
}
# txt (formatters) --------------------------------------------------------------------
#' @importFrom formatters export_as_txt
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2", "COUNTRY"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8))
#'
#' \dontrun{
#' tf <- tempfile(fileext = ".txt")
#' export_as_txt(tbl, file = tf)
#' system2("cat", tf)
#' }
#'
#' @export
formatters::export_as_txt

# pdf (formatters) ----------------------------------------------------------
#' @importFrom formatters export_as_pdf
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   analyze(c("AGE", "BMRKR2", "COUNTRY"))
#'
#' tbl <- build_table(lyt, ex_adsl)
#'
#' \dontrun{
#' tf <- tempfile(fileext = ".pdf")
#' export_as_pdf(tbl, file = tf, pg_height = 4)
#' tf <- tempfile(fileext = ".pdf")
#' export_as_pdf(tbl, file = tf, lpp = 8)
#' }
#'
#' @export
formatters::export_as_pdf

1		.reindex_one_pos <- function(refs, cur_idx_fun) {
2	2223x	if (length(refs) == 0) {
3	2157x	return(refs)
4		}
5
6	66x	lapply(refs, function(refi) {
7		## these can be symbols, e.g. ^, † now, those are
8		## special and don't get reindexed cause they're not numbered
9		## to begin with
10	71x	idx <- ref_index(refi)
11	71x	if (is.na(idx) \|\| !is.na(as.integer(idx))) {
12	71x	ref_index(refi) <- cur_idx_fun(refi)
13		}
14	71x	refi
15		})
16		}
17
18	56x	setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper"))
19
20		setMethod(
21		".idx_helper", "TableRow",
22		function(tr, cur_idx_fun) {
23	54x	row_footnotes(tr) <- .reindex_one_pos(
24	54x	row_footnotes(tr),
25	54x	cur_idx_fun
26		)
27
28	54x	cell_footnotes(tr) <- lapply(cell_footnotes(tr), ## crfs,
29	54x	.reindex_one_pos,
30	54x	cur_idx_fun = cur_idx_fun
31		)
32	54x	tr
33		}
34		)
35
36		setMethod(
37		".idx_helper", "VTableTree",
38		function(tr, cur_idx_fun) {
39	2x	if (!labelrow_visible(tr)) {
40		stop("got a row footnote on a non-visible label row. this should never happen") # nocov
41		}
42	2x	lr <- tt_labelrow(tr)
43
44	2x	row_footnotes(lr) <- .reindex_one_pos(
45	2x	row_footnotes(lr),
46	2x	cur_idx_fun
47		)
48
49	2x	tt_labelrow(tr) <- lr
50
51	2x	tr
52		}
53		)
54
55		index_col_refs <- function(tt, cur_idx_fun) {
56	419x	ctree <- coltree(tt)
57	419x	ctree <- .index_col_refs_inner(ctree, cur_idx_fun)
58	419x	coltree(tt) <- ctree
59	419x	tt
60		}
61
62		.index_col_refs_inner <- function(ctree, cur_idx_fun) {
63	1998x	col_footnotes(ctree) <- .reindex_one_pos(
64	1998x	col_footnotes(ctree),
65	1998x	cur_idx_fun
66		)
67
68	1998x	if (is(ctree, "LayoutColTree")) {
69	747x	tree_children(ctree) <- lapply(tree_children(ctree),
70	747x	.index_col_refs_inner,
71	747x	cur_idx_fun = cur_idx_fun
72		)
73		}
74	1998x	ctree
75		## cfs <- col_footnotes(ctree)
76		## if(length(unlist(cfs)) > 0) {
77		## col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs,
78		## function(refs) lapply(refs, function(refi) {
79		}
80
81		#' Update footnote indices on a built table
82		#'
83		#' Re-indexes footnotes within a built table.
84		#'
85		#' @inheritParams gen_args
86		#'
87		#' @details
88		#' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes
89		#' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based
90		#' on the full table.
91		#'
92		#' @note In the future this should not generally need to be called manually.
93		#'
94		#' @export
95		update_ref_indexing <- function(tt) {
96	419x	col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt))
97	419x	row_fnotes <- row_footnotes(tt)
98	419x	cell_fnotes <- cell_footnotes(tt)
99	419x	all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))
100	419x	all_fns <- unlist(t(all_fns))
101	419x	unique_fnotes <- unique(sapply(all_fns, ref_msg))
102
103	419x	cur_index <- function(ref_fn) {
104	71x	match(ref_msg(ref_fn), unique_fnotes)
105		}
106
107	419x	if (ncol(tt) > 0) {
108	419x	tt <- index_col_refs(tt, cur_index)
109		} ## col_info(tt) <- index_col_refs(col_info(tt), cur_index)
110		## TODO when column refs are a thing we will
111		## still need to do those here before returning!!!
112	419x	if (nrow(tt) == 0) {
113	16x	return(tt)
114		}
115
116	403x	rdf <- make_row_df(tt)
117
118	403x	rdf <- rdf[rdf$nreflines > 0, ]
119	403x	if (nrow(rdf) == 0) {
120	371x	return(tt)
121		}
122
123	32x	for (i in seq_len(nrow(rdf))) {
124	56x	path <- unname(rdf$path[[i]])
125	56x	tt_at_path(tt, path) <-
126	56x	.idx_helper(
127	56x	tt_at_path(tt, path),
128	56x	cur_index
129		)
130		}
131	32x	tt
132		}

1		#' Change indentation of all `rrows` in an `rtable`
2		#'
3		#' Change indentation of all `rrows` in an `rtable`
4		#'
5		#' @param x (`VTableTree`)\cr an `rtable` object.
6		#' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is
7		#' less than 0, the indentation is set to 0.
8		#'
9		#' @return `x` with its indent modifier incremented by `by`.
10		#'
11		#' @examples
12		#' is_setosa <- iris$Species == "setosa"
13		#' m_tbl <- rtable(
14		#' header = rheader(
15		#' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
16		#' rrow(NULL, "mean", "median", "mean", "median")
17		#' ),
18		#' rrow(
19		#' row.name = "All Species",
20		#' mean(iris$Sepal.Length), median(iris$Sepal.Length),
21		#' mean(iris$Petal.Length), median(iris$Petal.Length),
22		#' format = "xx.xx"
23		#' ),
24		#' rrow(
25		#' row.name = "Setosa",
26		#' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]),
27		#' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]),
28		#' format = "xx.xx"
29		#' )
30		#' )
31		#' indent(m_tbl)
32		#' indent(m_tbl, 2)
33		#'
34		#' @export
35		indent <- function(x, by = 1) {
36	9x	if (nrow(x) == 0 \|\| by == 0) {
37	9x	return(x)
38		}
39
40	!	indent_mod(x) <- indent_mod(x) + by
41	!	x
42		}
43
44		#' Clear all indent modifiers from a table
45		#'
46		#' @inheritParams gen_args
47		#'
48		#' @return The same class as `tt`, with all indent modifiers set to zero.
49		#'
50		#' @examples
51		#' lyt1 <- basic_table() %>%
52		#' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
53		#' split_rows_by("AEBODSYS", child_labels = "visible") %>%
54		#' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
55		#' analyze("AGE", indent_mod = -1L)
56		#'
57		#' tbl1 <- build_table(lyt1, ex_adae)
58		#' tbl1
59		#' clear_indent_mods(tbl1)
60		#'
61		#' @export
62		#' @rdname clear_imods
63	40x	setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))
64
65		#' @export
66		#' @rdname clear_imods
67		setMethod(
68		"clear_indent_mods", "VTableTree",
69		function(tt) {
70	25x	ct <- content_table(tt)
71	25x	if (!is.null(ct)) {
72	9x	content_table(tt) <- clear_indent_mods(ct)
73		}
74	25x	tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)
75	25x	indent_mod(tt) <- 0L
76	25x	tt
77		}
78		)
79
80		#' @export
81		#' @rdname clear_imods
82		setMethod(
83		"clear_indent_mods", "TableRow",
84		function(tt) {
85	15x	indent_mod(tt) <- 0L
86	15x	tt
87		}
88		)

1		#' Format `rcell` objects
2		#'
3		#' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects
4		#'
5		#' @inheritParams lyt_args
6		#' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value.
7		#' @param format (`string` or `function`)\cr the format label or formatter function to
8		#' apply to `x`.
9		#' @param output (`string`)\cr output type.
10		#' @param pr_row_format (`list`)\cr list of default formats coming from the general row.
11		#' @param pr_row_na_str (`list`)\cr list of default `"NA"` strings coming from the general row.
12		#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the
13		#' values with formats applied. Defaults to `FALSE`.
14		#'
15		#' @return Formatted text.
16		#'
17		#' @examples
18		#' cll <- CellValue(pi, format = "xx.xxx")
19		#' format_rcell(cll)
20		#'
21		#' # Cell values precedes the row values
22		#' cll <- CellValue(pi, format = "xx.xxx")
23		#' format_rcell(cll, pr_row_format = "xx.x")
24		#'
25		#' # Similarly for NA values
26		#' cll <- CellValue(NA, format = "xx.xxx", format_na_str = "This is THE NA")
27		#' format_rcell(cll, pr_row_na_str = "This is NA")
28		#'
29		#' @export
30		format_rcell <- function(x, format,
31		output = c("ascii", "html"),
32		na_str = obj_na_str(x) %\|\|% "NA",
33		pr_row_format = NULL,
34		pr_row_na_str = NULL,
35		shell = FALSE) {
36		# Check for format and parent row format
37	100808x	format <- if (missing(format)) obj_format(x) else format
38	100808x	if (is.null(format) && !is.null(pr_row_format)) {
39	72160x	format <- pr_row_format
40		}
41		# Check for na_str from parent
42	100808x	if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
43	86299x	na_str <- pr_row_na_str
44		}
45
46		# Main call to external function or shell
47	100808x	if (shell) {
48	26634x	return(format)
49		}
50	74174x	format_value(rawvalues(x),
51	74174x	format = format,
52	74174x	output = output,
53	74174x	na_str = na_str
54		)
55		}

1		insert_brs <- function(vec) {
2	1021x	if (length(vec) == 1) {
3	1021x	ret <- list(vec)
4		} else {
5	!	nout <- length(vec) * 2 - 1
6	!	ret <- vector("list", nout)
7	!	for (i in seq_along(vec)) {
8	!	ret[[2 * i - 1]] <- vec[i]
9	!	if (2 * i < nout) {
10	!	ret[[2 * i]] <- tags$br()
11		}
12		}
13		}
14	1021x	ret
15		}
16
17		div_helper <- function(lst, class) {
18	72x	do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst)))
19		}
20
21		#' Convert an `rtable` object to a `shiny.tag` HTML object
22		#'
23		#' The returned HTML object can be immediately used in `shiny` and `rmarkdown`.
24		#'
25		#' @param x (`VTableTree`)\cr a `TableTree` object.
26		#' @param class_table (`character`)\cr class for `table` tag.
27		#' @param class_tr (`character`)\cr class for `tr` tag.
28		#' @param class_th (`character`)\cr class for `th` tag.
29		#' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a
30		#' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`.
31		#' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table.
32		#' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`,
33		#' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label
34		#' rows). Defaults to `"header"`.
35		#' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults
36		#' to `TRUE`.
37		#' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults
38		#' to `FALSE`.
39		#' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`).
40		#' Doing this keeps the structure of the cells but may depend on the output device.
41		#'
42		#' @importFrom htmltools tags
43		#'
44		#' @return A `shiny.tag` object representing `x` in HTML.
45		#'
46		#' @examples
47		#' tbl <- rtable(
48		#' header = LETTERS[1:3],
49		#' format = "xx",
50		#' rrow("r1", 1, 2, 3),
51		#' rrow("r2", 4, 3, 2, indent = 1),
52		#' rrow("r3", indent = 2)
53		#' )
54		#'
55		#' as_html(tbl)
56		#'
57		#' as_html(tbl, class_table = "table", class_tr = "row")
58		#'
59		#' as_html(tbl, bold = c("header", "row_names"))
60		#'
61		#' \dontrun{
62		#' Viewer(tbl)
63		#' }
64		#'
65		#' @export
66		as_html <- function(x,
67		width = NULL,
68		class_table = "table table-condensed table-hover",
69		class_tr = NULL,
70		class_th = NULL,
71		link_label = NULL,
72		bold = c("header"),
73		header_sep_line = TRUE,
74		no_spaces_between_cells = FALSE,
75		expand_newlines = FALSE) {
76	9x	if (is.null(x)) {
77	!	return(tags$p("Empty Table"))
78		}
79
80	9x	stopifnot(is(x, "VTableTree"))
81
82	9x	mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines)
83
84	9x	nlh <- mf_nlheader(mat)
85	9x	nc <- ncol(x) + 1
86	9x	nr <- length(mf_lgrouping(mat))
87
88		# Structure is a list of lists with rows (one for each line grouping) and cols as dimensions
89	9x	cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc)
90
91	9x	for (i in seq_len(nr)) {
92	173x	for (j in seq_len(nc)) {
93	1021x	curstrs <- mf_strings(mat)[i, j]
94	1021x	curspn <- mf_spans(mat)[i, j]
95	1021x	algn <- mf_aligns(mat)[i, j]
96
97	1021x	inhdr <- i <= nlh
98	1021x	tagfun <- if (inhdr) tags$th else tags$td
99	1021x	cells[i, j][[1]] <- tagfun(
100	1021x	class = if (inhdr) class_th else class_tr,
101	1021x	style = paste0("text-align: ", algn, ";"),
102	1021x	style = if (inhdr && !"header" %in% bold) "font-weight: normal;",
103	1021x	style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;",
104	1021x	colspan = if (curspn != 1) curspn,
105	1021x	insert_brs(curstrs)
106		)
107		}
108		}
109
110	9x	if (header_sep_line) {
111	9x	cells[nlh][[1]] <- htmltools::tagAppendAttributes(
112	9x	cells[nlh, 1][[1]],
113	9x	style = "border-bottom: 1px solid black;"
114		)
115		}
116
117		# Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh
118	9x	map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping)
119	9x	row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh)
120	9x	map <- merge(map, row_info_df, by = "abs_rownumber")
121
122		# add indent values for headerlines
123	9x	map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map)
124
125
126		# Row labels style
127	9x	for (i in seq_len(nr)) {
128	173x	indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1)
129
130		# Apply indentation
131	173x	if (indent > 0) {
132	127x	cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
133	127x	cells[i, 1][[1]],
134	127x	style = paste0("padding-left: ", indent * 3, "ch;")
135		)
136		}
137
138		# Apply bold font weight if "row_names" is in 'bold'
139	173x	if ("row_names" %in% bold) {
140	4x	cells[i, 1][[1]] <- htmltools::tagAppendAttributes(
141	4x	cells[i, 1][[1]],
142	4x	style = "font-weight: bold;"
143		)
144		}
145		}
146
147		# label rows style
148	9x	if ("label_rows" %in% bold) {
149	!	which_lbl_rows <- which(mat$row_info$node_class == "LabelRow")
150	!	cells[which_lbl_rows + nlh, ] <- lapply(
151	!	cells[which_lbl_rows + nlh, ],
152	!	htmltools::tagAppendAttributes,
153	!	style = "font-weight: bold;"
154		)
155		}
156
157		# content rows style
158	9x	if ("content_rows" %in% bold) {
159	!	which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
160	!	cells[which_cntnt_rows + nlh, ] <- lapply(
161	!	cells[which_cntnt_rows + nlh, ],
162	!	htmltools::tagAppendAttributes,
163	!	style = "font-weight: bold;"
164		)
165		}
166
167	9x	if (any(!mat$display)) {
168		# Check that expansion kept the same display info
169	2x	check_expansion <- c()
170	2x	for (ii in unique(mat$line_grouping)) {
171	121x	rows <- which(mat$line_grouping == ii)
172	121x	check_expansion <- c(
173	121x	check_expansion,
174	121x	apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) \|\| all(!x))
175		)
176		}
177
178	2x	if (!all(check_expansion)) {
179	!	stop(
180	!	"Found that a group of rows have different display options even if ",
181	!	"they belong to the same line group. This should not happen. Please ",
182	!	"file an issue or report to the maintainers."
183	!	) # nocov
184		}
185
186	2x	for (ii in unique(mat$line_grouping)) {
187	121x	rows <- which(mat$line_grouping == ii)
188	121x	should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)
189	121x	cells[ii, !should_display_col] <- NA_integer_
190		}
191		}
192
193	9x	rows <- apply(cells, 1, function(row) {
194	173x	tags$tr(
195	173x	class = class_tr,
196	173x	style = "white-space: pre;",
197	173x	Filter(function(x) !identical(x, NA_integer_), row)
198		)
199		})
200
201	9x	hsep_line <- tags$hr(class = "solid")
202
203	9x	hdrtag <- div_helper(
204	9x	class = "rtables-titles-block",
205	9x	list(
206	9x	div_helper(
207	9x	class = "rtables-main-titles-block",
208	9x	lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
209	9x	class = "rtables-main-title"
210		)
211		),
212	9x	div_helper(
213	9x	class = "rtables-subtitles-block",
214	9x	lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
215	9x	class = "rtables-subtitle"
216		)
217		)
218		)
219		)
220
221	9x	tabletag <- do.call(
222	9x	tags$table,
223	9x	c(
224	9x	rows,
225	9x	list(
226	9x	class = class_table,
227	9x	style = paste(
228	9x	if (no_spaces_between_cells) "border-collapse: collapse;",
229	9x	if (!is.null(width)) paste("width:", width)
230		),
231	9x	tags$caption(sprintf("(\\#tag:%s)", link_label),
232	9x	style = "caption-side: top;",
233	9x	.noWS = "after-begin"
234		)
235		)
236		)
237		)
238
239	9x	rfnotes <- div_helper(
240	9x	class = "rtables-ref-footnotes-block",
241	9x	lapply(mat$ref_footnotes, tags$p,
242	9x	class = "rtables-referential-footnote"
243		)
244		)
245
246	9x	mftr <- div_helper(
247	9x	class = "rtables-main-footers-block",
248	9x	lapply(main_footer(x), tags$p,
249	9x	class = "rtables-main-footer"
250		)
251		)
252
253	9x	pftr <- div_helper(
254	9x	class = "rtables-prov-footers-block",
255	9x	lapply(prov_footer(x), tags$p,
256	9x	class = "rtables-prov-footer"
257		)
258		)
259
260		## XXX this omits the divs entirely if they are empty. Do we want that or do
261		## we want them to be there but empty??
262	9x	ftrlst <- list(
263	9x	if (length(mat$ref_footnotes) > 0) rfnotes,
264	9x	if (length(mat$ref_footnotes) > 0) hsep_line,
265	9x	if (length(main_footer(x)) > 0) mftr,
266	9x	if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break
267	9x	if (length(prov_footer(x)) > 0) pftr
268		)
269
270	!	if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst)
271	9x	ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)]
272
273	9x	ftrtag <- div_helper(
274	9x	class = "rtables-footers-block",
275	9x	ftrlst
276		)
277
278	9x	div_helper(
279	9x	class = "rtables-all-parts-block",
280	9x	list(
281	9x	hdrtag,
282	9x	tabletag,
283	9x	ftrtag
284		)
285		)
286		}

1		#' Find degenerate (sub)structures within a table
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if
6		#' they have associated content rows).
7		#'
8		#' @param tt (`TableTree`)\cr a `TableTree` object.
9		#'
10		#' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table.
11		#'
12		#' @examples
13		#' find_degen_struct(rtable("hi"))
14		#'
15		#' @family table structure validation functions
16		#' @export
17		find_degen_struct <- function(tt) {
18	7x	degen <- list()
19
20	7x	recurse_check <- function(tti, path) {
21	103x	if (is(tti, "VTableTree")) {
22	103x	kids <- tree_children(tti)
23	103x	if (length(kids) == 0) {
24	69x	degen <<- c(degen, list(path))
25		} else {
26	34x	for (i in seq_along(kids)) {
27	96x	recurse_check(kids[[i]], path = c(path, names(kids)[i]))
28		}
29		}
30		}
31		}
32	7x	recurse_check(tt, obj_name(tt) %\|\|% "root")
33	7x	degen
34		}
35
36		#' Validate and assert valid table structure
37		#'
38		#' @description `r lifecycle::badge("experimental")`
39		#'
40		#' A `TableTree` (`rtables`-built table) is considered degenerate if:
41		#' \enumerate{
42		#' \item{It contains no subtables or data rows (content rows do not count).}
43		#' \item{It contains a subtable which is degenerate by the criterion above.}
44		#' }
45		#'
46		#' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure.
47		#'
48		#' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or
49		#' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more
50		#' invalid substructures.
51		#'
52		#' @param tt (`TableTree`)\cr a `TableTree` object.
53		#'
54		#' @return
55		#' * `validate_table_struct` returns a logical value indicating valid structure.
56		#' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables.
57		#'
58		#' @note This function is experimental and the exact text of the warning/error is subject to change in future releases.
59		#'
60		#' @examples
61		#' validate_table_struct(rtable("hahaha"))
62		#' \dontrun{
63		#' assert_valid_table(rtable("oops"))
64		#' }
65		#'
66		#' @family table structure validation functions
67		#' @export
68		validate_table_struct <- function(tt) {
69	1x	degen_pths <- find_degen_struct(tt)
70	1x	length(degen_pths) == 0
71		}
72
73		## XXX this doesn't handle content paths correctly
74		.path_to_disp <- function(pth) {
75	4x	if (length(pth) == 1) {
76	1x	return(pth)
77		}
78	3x	has_cont <- any(pth == "@content")
79	3x	if (has_cont) {
80	!	contpos <- which(pth == "@content")
81	!	cont_disp <- paste(tail(pth, length(pth) - contpos + 1),
82	!	collapse = "->"
83		)
84	!	pth <- head(pth, contpos)
85		} else {
86	3x	cont_disp <- character()
87		}
88
89	3x	topaste <- character(0)
90	3x	fullpth <- pth
91	3x	while (length(pth) > 0) {
92	6x	if (length(pth) <= 1) {
93	!	topaste <- c(topaste, pth)
94	!	pth <- character()
95		} else {
96	6x	topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
97	6x	pth <- tail(pth, -2)
98		}
99		}
100	3x	topaste <- c(topaste, cont_disp)
101	3x	paste(topaste, collapse = "->")
102		}
103
104		no_analyze_guess <- paste0(
105		"Was this table created using ",
106		"summarize_row_groups but no calls ",
107		"to analyze?\n"
108		)
109
110		use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues")
111
112		make_degen_message <- function(degen_pths, tt) {
113	2x	msg <- sprintf(
114	2x	paste0(
115	2x	"Invalid table - found %d (sub)structures which contain no data rows.",
116	2x	"\n\tThe first occured at path: %s"
117		),
118	2x	length(degen_pths), .path_to_disp(degen_pths[[1]])
119		)
120	2x	if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
121	1x	msg <- paste(msg, " Likely Cause: Empty data or first row split on variable with only NA values",
122	1x	sep = "\n"
123		)
124	1x	} else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
125	1x	msg <- paste(msg, " Cause: Layout did not contain any analyze() calls (only summarize_row_groups())",
126	1x	sep = "\n"
127		)
128		}
129	2x	msg <- paste(msg, use_sanitize_msg, sep = "\n")
130	2x	msg
131		}
132
133		#' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`.
134		#'
135		#' @rdname validate_table_struct
136		#' @export
137		assert_valid_table <- function(tt, warn_only = FALSE) {
138	2x	degen_pths <- find_degen_struct(tt)
139	2x	if (length(degen_pths) == 0) {
140	!	return(TRUE)
141		}
142
143		## we failed, now we build an informative error/warning message
144	2x	msg <- make_degen_message(degen_pths, tt)
145
146	2x	if (!warn_only) {
147	2x	stop(msg)
148		}
149	!	warning(msg)
150	!	return(FALSE)
151		}
152
153		#' Sanitize degenerate table structures
154		#'
155		#' @description `r lifecycle::badge("experimental")`
156		#'
157		#' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures.
158		#'
159		#' @param tt (`TableTree`)\cr a `TableTree` object.
160		#' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows.
161		#'
162		#' @details
163		#' This function locates degenerate portions of the table (including the table overall in the case of a table with no
164		#' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table
165		#' guaranteed to be non-degenerate.
166		#'
167		#' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate
168		#' version of the table is returned.
169		#'
170		#' @examples
171		#' sanitize_table_struct(rtable("cool beans"))
172		#'
173		#' lyt <- basic_table() %>%
174		#' split_cols_by("ARM") %>%
175		#' split_rows_by("SEX") %>%
176		#' summarize_row_groups()
177		#'
178		#' ## Degenerate because it doesn't have any analyze calls -> no data rows
179		#' badtab <- build_table(lyt, DM)
180		#' sanitize_table_struct(badtab)
181		#'
182		#' @family table structure validation functions
183		#' @export
184		sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
185	4x	rdf <- make_row_df(tt)
186
187	4x	emptyrow <- DataRow(
188	4x	vals = list(empty_msg),
189	4x	name = "empty_section",
190	4x	label = "",
191	4x	cspan = ncol(tt),
192	4x	cinfo = col_info(tt),
193	4x	format = "xx",
194	4x	table_inset = table_inset(tt)
195		)
196	4x	degen_pths <- find_degen_struct(tt)
197
198	4x	if (identical(degen_pths, list("root"))) {
199	2x	tree_children(tt) <- list(empty_row = emptyrow)
200	2x	return(tt)
201		}
202
203	2x	for (pth in degen_pths) {
204		## FIXME this shouldn't be necessary. why is it?
205	33x	tti <- tt_at_path(tt, path = pth)
206	33x	tree_children(tti) <- list(empty_section = emptyrow)
207	33x	tt_at_path(tt, path = pth) <- tti
208		}
209	2x	tt
210		}

1		#' Trimming and pruning criteria
2		#'
3		#' Criteria functions (and constructors thereof) for trimming and pruning tables.
4		#'
5		#' @inheritParams gen_args
6		#'
7		#' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning.
8		#'
9		#' @seealso [prune_table()], [trim_rows()]
10		#'
11		#' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any non-`LabelRow`
12		#' `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values.
13		#'
14		#' @examples
15		#' adsl <- ex_adsl
16		#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
17		#' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0
18		#' adsl$BMRKR1 <- 0
19		#'
20		#' tbl_to_prune <- basic_table() %>%
21		#' analyze("BMRKR1") %>%
22		#' split_cols_by("ARM") %>%
23		#' split_rows_by("SEX") %>%
24		#' summarize_row_groups() %>%
25		#' split_rows_by("STRATA1") %>%
26		#' summarize_row_groups() %>%
27		#' analyze("AGE") %>%
28		#' build_table(adsl)
29		#'
30		#' tbl_to_prune %>% prune_table(all_zero_or_na)
31		#'
32		#' @rdname trim_prune_funs
33		#' @export
34		all_zero_or_na <- function(tr) {
35	347x	if (!is(tr, "TableRow") \|\| is(tr, "LabelRow")) {
36	93x	return(FALSE)
37		}
38	254x	rvs <- unlist(unname(row_values(tr)))
39	254x	all(is.na(rvs) \| rvs == 0 \| !is.finite(rvs))
40		}
41
42		#' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values.
43		#'
44		#' @examples
45		#' tbl_to_prune %>% prune_table(all_zero)
46		#'
47		#' @rdname trim_prune_funs
48		#' @export
49		all_zero <- function(tr) {
50	8x	if (!is(tr, "TableRow") \|\| is(tr, "LabelRow")) {
51	!	return(FALSE)
52		}
53	8x	rvs <- unlist(unname(row_values(tr)))
54	8x	isTRUE(all(rvs == 0))
55		}
56
57		#' Trim rows from a populated table without regard for table structure
58		#'
59		#' @inheritParams gen_args
60		#' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row
61		#' should be removed. Defaults to [all_zero_or_na()].
62		#'
63		#' @return The table with rows that have only `NA` or 0 cell values removed.
64		#'
65		#' @note
66		#' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or
67		#' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on
68		#' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead.
69		#'
70		#' @details
71		#' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()]
72		#' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure
73		#' into account.
74		#'
75		#' @seealso [prune_table()]
76		#'
77		#' @examples
78		#' adsl <- ex_adsl
79		#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
80		#'
81		#' tbl_to_trim <- basic_table() %>%
82		#' analyze("BMRKR1") %>%
83		#' split_cols_by("ARM") %>%
84		#' split_rows_by("SEX") %>%
85		#' summarize_row_groups() %>%
86		#' split_rows_by("STRATA1") %>%
87		#' summarize_row_groups() %>%
88		#' analyze("AGE") %>%
89		#' build_table(adsl)
90		#'
91		#' tbl_to_trim %>% trim_rows()
92		#'
93		#' tbl_to_trim %>% trim_rows(all_zero)
94		#'
95		#' @export
96		trim_rows <- function(tt, criteria = all_zero_or_na) {
97	3x	rows <- collect_leaves(tt, TRUE, TRUE)
98	3x	torm <- vapply(rows, criteria,
99	3x	NA,
100	3x	USE.NAMES = FALSE
101		)
102	3x	tt[!torm, ,
103	3x	keep_topleft = TRUE,
104	3x	keep_titles = TRUE,
105	3x	keep_footers = TRUE,
106	3x	reindex_refs = TRUE
107		]
108		}
109
110		#' @inheritParams trim_rows
111		#'
112		#' @details
113		#' `content_all_zeros_nas` prunes a subtable if both of the following are true:
114		#'
115		#' * It has a content table with exactly one row in it.
116		#' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content
117		#' function is used, this represents pruning any subtable which corresponds to an empty set of the input data
118		#' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data).
119		#'
120		#' @examples
121		#' tbl_to_prune %>% prune_table(content_all_zeros_nas)
122		#'
123		#' @rdname trim_prune_funs
124		#' @export
125		content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
126		## this will be NULL if
127		## tt is something that doesn't have a content table
128	254x	ct <- content_table(tt)
129		## NROW returns 0 for NULL.
130	254x	if (NROW(ct) == 0 \|\| nrow(ct) > 1) {
131	242x	return(FALSE)
132		}
133
134	12x	cr <- tree_children(ct)[[1]]
135	12x	criteria(cr)
136		}
137
138		#' @details
139		#' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on
140		#' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no
141		#' children.
142		#'
143		#' @examples
144		#' tbl_to_prune %>% prune_table(prune_empty_level)
145		#'
146		#' @rdname trim_prune_funs
147		#' @export
148		prune_empty_level <- function(tt) {
149	389x	if (is(tt, "TableRow")) {
150	151x	return(all_zero_or_na(tt))
151		}
152
153	238x	if (content_all_zeros_nas(tt)) {
154	2x	return(TRUE)
155		}
156	236x	kids <- tree_children(tt)
157	236x	length(kids) == 0
158		}
159
160		#' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes
161		#' only in the case of all non-missing zero values.
162		#'
163		#' @examples
164		#' tbl_to_prune %>% prune_table(prune_zeros_only)
165		#'
166		#' @rdname trim_prune_funs
167		#' @export
168		prune_zeros_only <- function(tt) {
169	16x	if (is(tt, "TableRow")) {
170	8x	return(all_zero(tt))
171		}
172
173	8x	if (content_all_zeros_nas(tt, criteria = all_zero)) {
174	!	return(TRUE)
175		}
176	8x	kids <- tree_children(tt)
177	8x	length(kids) == 0
178		}
179
180		#' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value.
181		#' Subtables whose combined/average count are below this threshold will be pruned.
182		#' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`.
183		#'
184		#' @details
185		#' `low_obs_pruner` is a constructor function which, when called, returns a pruning criteria function which
186		#' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell
187		#' values (defined as the first value per cell regardless of how many values per cell there are) against `min`.
188		#'
189		#' @examples
190		#' min_prune <- low_obs_pruner(70, "sum")
191		#' tbl_to_prune %>% prune_table(min_prune)
192		#'
193		#' @rdname trim_prune_funs
194		#' @export
195		low_obs_pruner <- function(min, type = c("sum", "mean")) {
196	3x	type <- match.arg(type)
197	3x	function(tt) {
198	21x	if (is(tt, "TableRow") \|\| NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
199	9x	return(FALSE) ## only trimming on count content rows
200		}
201	12x	ctr <- tree_children(ctab)[[1]]
202	12x	vals <- sapply(row_values(ctr), function(v) v[[1]])
203	12x	sumvals <- sum(vals)
204	12x	if (type == "mean") {
205	8x	sumvals <- sumvals / length(vals)
206		}
207	12x	sumvals < min
208		}
209		}
210
211		#' Recursively prune a `TableTree`
212		#'
213		#' @inheritParams gen_args
214		#' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the
215		#' entire subtree should be removed.
216		#' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.
217		#' Defaults to `NA` which indicates pruning should happen at all levels.
218		#' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.
219		#'
220		#' @return A `TableTree` pruned via recursive application of `prune_func`.
221		#'
222		#' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included
223		#' in the `rtables` package.
224		#'
225		#' @examples
226		#' adsl <- ex_adsl
227		#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")
228		#'
229		#' tbl_to_prune <- basic_table() %>%
230		#' split_cols_by("ARM") %>%
231		#' split_rows_by("SEX") %>%
232		#' summarize_row_groups() %>%
233		#' split_rows_by("STRATA1") %>%
234		#' summarize_row_groups() %>%
235		#' analyze("AGE") %>%
236		#' build_table(adsl)
237		#'
238		#' tbl_to_prune %>% prune_table()
239		#'
240		#' @export
241		prune_table <- function(tt,
242		prune_func = prune_empty_level,
243		stop_depth = NA_real_,
244		depth = 0) {
245	323x	if (!is.na(stop_depth) && depth > stop_depth) {
246	!	return(tt)
247		}
248	323x	if (is(tt, "TableRow")) {
249	54x	if (prune_func(tt)) {
250	!	tt <- NULL
251		}
252	54x	return(tt)
253		}
254
255	269x	kids <- tree_children(tt)
256
257	269x	torm <- vapply(kids, function(tb) {
258	386x	!is.null(tb) && prune_func(tb)
259	269x	}, NA)
260
261	269x	keepkids <- kids[!torm]
262	269x	keepkids <- lapply(keepkids, prune_table,
263	269x	prune_func = prune_func,
264	269x	stop_depth = stop_depth,
265	269x	depth = depth + 1
266		)
267
268	269x	keepkids <- keepkids[!vapply(keepkids, is.null, NA)]
269	269x	if (length(keepkids) > 0) {
270	135x	tree_children(tt) <- keepkids
271		} else {
272	134x	tt <- NULL
273		}
274	269x	tt
275		}

1		#' Cell value constructors
2		#'
3		#' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.
4		#'
5		#' @inheritParams compat_args
6		#' @inheritParams lyt_args
7		#' @param x (`ANY`)\cr cell value.
8		#' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.
9		#' See [formatters::list_valid_format_labels()] for currently supported format labels.
10		#' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.
11		#' @param colspan (`integer(1)`)\cr column span value.
12		#' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.
13		#'
14		#' @inherit CellValue return
15		#'
16		#' @note Currently column spanning is only supported for defining header structure.
17		#'
18		#' @rdname rcell
19		#' @export
20		rcell <- function(x,
21		format = NULL,
22		colspan = 1L,
23		label = NULL,
24		indent_mod = NULL,
25		footnotes = NULL,
26		align = NULL,
27		format_na_str = NULL) {
28	31800x	if (!is.null(align)) {
29	56x	check_aligns(align)
30		}
31	31800x	if (is(x, "CellValue")) {
32	19183x	if (!is.null(label)) {
33	1x	obj_label(x) <- label
34		}
35	19183x	if (colspan != 1L) {
36	1x	cell_cspan(x) <- colspan
37		}
38	19183x	if (!is.null(indent_mod)) {
39	1x	indent_mod(x) <- indent_mod
40		}
41	19183x	if (!is.null(format)) {
42	1x	obj_format(x) <- format
43		}
44	19183x	if (!is.null(footnotes)) {
45	366x	cell_footnotes(x) <- lapply(footnotes, RefFootnote)
46		}
47	19183x	if (!is.null(format_na_str)) {
48	!	obj_na_str(x) <- format_na_str
49		}
50	19183x	ret <- x
51		} else {
52	12617x	if (is.null(label)) {
53	9735x	label <- obj_label(x)
54		}
55	12617x	if (is.null(format)) {
56	6779x	format <- obj_format(x)
57		}
58	12617x	if (is.null(indent_mod)) {
59	12617x	indent_mod <- indent_mod(x)
60		}
61	12617x	footnotes <- lapply(footnotes, RefFootnote)
62	12617x	ret <- CellValue(
63	12617x	val = x,
64	12617x	format = format,
65	12617x	colspan = colspan,
66	12617x	label = label,
67	12617x	indent_mod = indent_mod,
68	12617x	footnotes = footnotes,
69	12617x	format_na_str = format_na_str
70	12617x	) # RefFootnote(footnote))
71		}
72	31800x	if (!is.null(align)) {
73	56x	cell_align(ret) <- align
74		}
75	31800x	ret
76		}
77
78		#' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be
79		#' passed to this argument).
80		#' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.
81		#'
82		#' @details
83		#' `non_ref_rcell` provides the common blank for cells in the reference column, this value otherwise, and should
84		#' be passed the value of `.in_ref_col` when it is used.
85		#'
86		#' @rdname rcell
87		#' @export
88		non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,
89		label = NULL, indent_mod = NULL,
90		refval = NULL,
91		align = "center",
92		format_na_str = NULL) {
93	2x	val <- if (is_ref) refval else x
94	2x	rcell(val,
95	2x	format = format, colspan = colspan, label = label,
96	2x	indent_mod = indent_mod, align = align,
97	2x	format_na_str = format_na_str
98		)
99		}
100
101		#' Create multiple rows in analysis or summary functions
102		#'
103		#' Define the cells that get placed into multiple rows in `afun`.
104		#'
105		#' @param ... single row defining expressions.
106		#' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.
107		#' @param .names (`character` or `NULL`)\cr names of the returned list/structure.
108		#' @param .labels (`character` or `NULL`)\cr labels for the defined rows.
109		#' @param .formats (`character` or `NULL`)\cr formats for the values.
110		#' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.
111		#' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with cells.
112		#' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with rows.
113		#' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.
114		#' See [formatters::list_valid_aligns()] for currently supported alignments.
115		#' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.
116		#'
117		#' @note In post-processing, referential footnotes can also be added using row and column
118		#' paths with [`fnotes_at_path<-`].
119		#'
120		#' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an
121		#' internal implementation detail.
122		#'
123		#' @seealso [analyze()]
124		#'
125		#' @examples
126		#' in_rows(1, 2, 3, .names = c("a", "b", "c"))
127		#' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
128		#' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
129		#'
130		#' in_rows(.list = list(a = 1, b = 2, c = 3))
131		#' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
132		#'
133		#' lyt <- basic_table() %>%
134		#' split_cols_by("ARM") %>%
135		#' analyze("AGE", afun = function(x) {
136		#' in_rows(
137		#' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),
138		#' "Range" = rcell(range(x), format = "xx.xx - xx.xx")
139		#' )
140		#' })
141		#'
142		#' tbl <- build_table(lyt, ex_adsl)
143		#' tbl
144		#'
145		#' @export
146		in_rows <- function(..., .list = NULL, .names = NULL,
147		.labels = NULL,
148		.formats = NULL,
149		.indent_mods = NULL,
150		.cell_footnotes = list(NULL),
151		.row_footnotes = list(NULL),
152		.aligns = NULL,
153		.format_na_strs = NULL) {
154	5775x	if (is.function(.formats)) {
155	!	.formats <- list(.formats)
156		}
157
158	5775x	l <- c(list(...), .list)
159
160	5775x	if (missing(.names) && missing(.labels)) {
161	1766x	if (length(l) > 0 && is.null(names(l))) {
162	!	stop("need a named list")
163		} else {
164	1766x	.names <- names(l)
165		}
166	1766x	stopifnot(!anyNA(.names))
167		}
168
169	5775x	if (length(l) == 0) {
170		if (
171	!	length(.labels) > 0 \|\|
172	!	length(.formats) > 0 \|\|
173	!	length(.names) > 0 \|\|
174	!	length(.indent_mods) > 0 \|\|
175	!	length(.format_na_strs) > 0
176		) {
177	!	stop(
178	!	"in_rows got 0 rows but length >0 of at least one of ",
179	!	".labels, .formats, .names, .indent_mods, .format_na_strs. ",
180	!	"Does your analysis/summary function handle the 0 row ",
181	!	"df/length 0 x case?"
182		)
183		}
184	!	l2 <- list()
185		} else {
186	5775x	if (is.null(.formats)) {
187	5315x	.formats <- list(NULL)
188		}
189	5775x	stopifnot(is.list(.cell_footnotes))
190	5775x	if (length(.cell_footnotes) != length(l)) {
191	1187x	.cell_footnotes <- c(
192	1187x	.cell_footnotes,
193	1187x	setNames(
194	1187x	rep(list(character()),
195	1187x	length.out = length(setdiff(
196	1187x	names(l),
197	1187x	names(.cell_footnotes)
198		))
199		),
200	1187x	setdiff(
201	1187x	names(l),
202	1187x	names(.cell_footnotes)
203		)
204		)
205		)
206	1187x	.cell_footnotes <- .cell_footnotes[names(l)]
207		}
208	5775x	if (is.null(.aligns)) {
209	5772x	.aligns <- list(NULL)
210		}
211	5775x	l2 <- mapply(rcell,
212	5775x	x = l, format = .formats,
213	5775x	footnotes = .cell_footnotes %\|\|% list(NULL),
214	5775x	align = .aligns,
215	5775x	format_na_str = .format_na_strs %\|\|% list(NULL),
216	5775x	SIMPLIFY = FALSE
217		)
218		}
219	5775x	if (is.null(.labels)) {
220	2623x	objlabs <- vapply(l2, function(x) obj_label(x) %\|\|% "", "")
221	2623x	if (any(nzchar(objlabs))) {
222	69x	.labels <- objlabs
223		}
224		}
225
226	5775x	if (is.null(.names) && !is.null(names(l))) {
227	97x	.names <- names(l)
228		}
229	5775x	stopifnot(is.list(.row_footnotes))
230	5775x	if (length(.row_footnotes) != length(l2)) {
231	1187x	tmp <- .row_footnotes
232	1187x	.row_footnotes <- vector("list", length(l2))
233	1187x	pos <- match(names(tmp), .names)
234	1187x	nonna <- which(!is.na(pos))
235	1187x	.row_footnotes[pos] <- tmp[nonna]
236		# length(.row_footnotes) <- length(l2)
237		}
238	5775x	ret <- RowsVerticalSection(l2,
239	5775x	names = .names,
240	5775x	labels = .labels,
241	5775x	indent_mods = .indent_mods,
242	5775x	formats = .formats,
243	5775x	footnotes = .row_footnotes,
244	5775x	format_na_strs = .format_na_strs
245		)
246		## if(!is.null(.names))
247		## names(l2) <- .names
248		## else
249		## names(l2) <- names(l)
250	!	if (length(ret) == 0) NULL else ret
251
252		## if (length(l) == 0) NULL else l
253		}
254
255		.validate_nms <- function(vals, .stats, arg) {
256	268x	if (!is.null(arg)) {
257	112x	if (is.null(names(arg))) {
258	!	stopifnot(length(arg) == length(.stats))
259	!	names(arg) <- names(vals)
260		} else {
261	112x	lblpos <- match(names(arg), names(vals))
262	112x	stopifnot(!anyNA(lblpos))
263		}
264		}
265	268x	arg
266		}
267
268		#' Create a custom analysis function wrapping an existing function
269		#'
270		#' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.
271		#' `fun` should return a named `list`.
272		#' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.
273		#' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.
274		#' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.
275		#' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.
276		#' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.
277		#' @param ... additional arguments to `fun` which effectively become new defaults. These can still be
278		#' overridden by `extra_args` within a split.
279		#' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the
280		#' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note
281		#' this argument occurs after `...` so it must be fully specified by name when set.
282		#' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.
283		#'
284		#' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling
285		#' performed automatically.
286		#'
287		#' @note
288		#' Setting `.ungroup_stats` to non-`NULL` changes the structure of the value(s) returned by `fun`, rather than
289		#' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that
290		#' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,
291		#' not the original structure returned by `fun`. See the final pair of examples below.
292		#'
293		#' @seealso [analyze()]
294		#'
295		#' @examples
296		#' s_summary <- function(x) {
297		#' stopifnot(is.numeric(x))
298		#'
299		#' list(
300		#' n = sum(!is.na(x)),
301		#' mean_sd = c(mean = mean(x), sd = sd(x)),
302		#' min_max = range(x)
303		#' )
304		#' }
305		#'
306		#' s_summary(iris$Sepal.Length)
307		#'
308		#' a_summary <- make_afun(
309		#' fun = s_summary,
310		#' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),
311		#' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")
312		#' )
313		#'
314		#' a_summary(x = iris$Sepal.Length)
315		#'
316		#' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
317		#'
318		#' a_summary2(x = iris$Sepal.Length)
319		#'
320		#' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))
321		#'
322		#' s_foo <- function(df, .N_col, a = 1, b = 2) {
323		#' list(
324		#' nrow_df = nrow(df),
325		#' .N_col = .N_col,
326		#' a = a,
327		#' b = b
328		#' )
329		#' }
330		#'
331		#' s_foo(iris, 40)
332		#'
333		#' a_foo <- make_afun(s_foo,
334		#' b = 4,
335		#' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),
336		#' .labels = c(
337		#' nrow_df = "Nrow df",
338		#' ".N_col" = "n in cols", a = "a value", b = "b value"
339		#' ),
340		#' .indent_mods = c(nrow_df = 2L, a = 1L)
341		#' )
342		#'
343		#' a_foo(iris, .N_col = 40)
344		#' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))
345		#' a_foo2(iris, .N_col = 40)
346		#'
347		#' # grouping and further customization
348		#' s_grp <- function(df, .N_col, a = 1, b = 2) {
349		#' list(
350		#' nrow_df = nrow(df),
351		#' .N_col = .N_col,
352		#' letters = list(
353		#' a = a,
354		#' b = b
355		#' )
356		#' )
357		#' }
358		#' a_grp <- make_afun(s_grp,
359		#' b = 3,
360		#' .labels = c(
361		#' nrow_df = "row count",
362		#' .N_col = "count in column"
363		#' ),
364		#' .formats = c(nrow_df = "xx.", .N_col = "xx."),
365		#' .indent_mods = c(letters = 1L),
366		#' .ungroup_stats = "letters"
367		#' )
368		#' a_grp(iris, 40)
369		#' a_aftergrp <- make_afun(a_grp,
370		#' .stats = c("nrow_df", "b"),
371		#' .formats = c(b = "xx.")
372		#' )
373		#' a_aftergrp(iris, 40)
374		#'
375		#' s_ref <- function(x, .in_ref_col, .ref_group) {
376		#' list(
377		#' mean_diff = mean(x) - mean(.ref_group)
378		#' )
379		#' }
380		#'
381		#' a_ref <- make_afun(s_ref,
382		#' .labels = c(mean_diff = "Mean Difference from Ref")
383		#' )
384		#' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)
385		#' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)
386		#'
387		#' @export
388		make_afun <- function(fun,
389		.stats = NULL,
390		.formats = NULL,
391		.labels = NULL,
392		.indent_mods = NULL,
393		.ungroup_stats = NULL,
394		.format_na_strs = NULL,
395		...,
396		.null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
397		## there is a LOT more computing-on-the-language hackery in here that I
398		## would prefer, but currently this is the way I see to do everything we
399		## want to do.
400
401		## too clever by three-quarters (because half wasn't enough)
402		## gross scope hackery
403	23x	fun_args <- force(list(...))
404	23x	fun_fnames <- names(formals(fun))
405
406		## force EVERYTHING otherwise calling this within loops is the stuff of
407		## nightmares
408	23x	force(.stats)
409	23x	force(.formats)
410	23x	force(.format_na_strs)
411	23x	force(.labels)
412	23x	force(.indent_mods)
413	23x	force(.ungroup_stats)
414	23x	force(.null_ref_cells) ## this one probably isn't needed?
415
416	23x	ret <- function(x, ...) { ## remember formals get clobbered here
417
418		## this helper will grab the value and wrap it in a named list if
419		## we need the variable and return list() otherwise.
420		## We define it in here so that the scoping hackery works correctly
421	66x	.if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
422	660x	val <- if (nm %in% fun_fnames) get(nm) else ifnot
423	660x	if (named_lwrap && !identical(val, ifnot)) {
424	78x	setNames(list(val), nm)
425		} else {
426	582x	val
427		}
428		}
429
430	66x	custargs <- fun_args
431
432		## special handling cause I need it at the bottom as well
433	66x	in_rc_argl <- .if_in_formals(".in_ref_col")
434	66x	.in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE
435
436	66x	sfunargs <- c(
437		## these are either named lists containing the arg, or list()
438		## depending on whether fun accept the argument or not
439	66x	.if_in_formals("x"),
440	66x	.if_in_formals("df"),
441	66x	.if_in_formals(".N_col"),
442	66x	.if_in_formals(".N_total"),
443	66x	.if_in_formals(".N_row"),
444	66x	.if_in_formals(".ref_group"),
445	66x	in_rc_argl,
446	66x	.if_in_formals(".df_row"),
447	66x	.if_in_formals(".var"),
448	66x	.if_in_formals(".ref_full")
449		)
450
451	66x	allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
452		## values int he actual call to this function override customization
453		## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE
454	66x	if ("..." %in% fun_fnames) {
455	5x	exargs <- eval(parser_helper(text = "list(...)"))
456	5x	custargs[names(exargs)] <- exargs
457	5x	allvars <- unique(c(allvars, names(custargs)))
458		}
459
460	66x	for (var in allvars) {
461		## not missing, i.e. specified in the direct call, takes precedence
462	22x	if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
463	5x	sfunargs[[var]] <- get(var)
464	17x	} else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
465	4x	sfunargs[[var]] <- custargs[[var]]
466		}
467		## else left out so we hit the original default we inherited from fun
468		}
469
470	66x	rawvals <- do.call(fun, sfunargs)
471
472		## note single brackets here so its a list
473		## no matter what. thats important!
474	66x	final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]
475
476	66x	if (!is.list(rawvals)) {
477	!	stop("make_afun expects a function fun that always returns a list")
478		}
479	66x	if (!is.null(.stats)) {
480	10x	stopifnot(all(.stats %in% names(rawvals)))
481		} else {
482	56x	.stats <- names(rawvals)
483		}
484	66x	if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
485	!	stop(
486	!	"Stats specified for ungrouping not included in non-null .stats list: ",
487	!	setdiff(.ungroup_stats, .stats)
488		)
489		}
490
491	66x	.labels <- .validate_nms(final_vals, .stats, .labels)
492	66x	.formats <- .validate_nms(final_vals, .stats, .formats)
493	66x	.indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)
494	66x	.format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)
495
496	66x	final_labels <- value_labels(final_vals)
497	66x	final_labels[names(.labels)] <- .labels
498
499	66x	final_formats <- lapply(final_vals, obj_format)
500	66x	final_formats[names(.formats)] <- .formats
501
502	66x	final_format_na_strs <- lapply(final_vals, obj_na_str)
503	66x	final_format_na_strs[names(.format_na_strs)] <- .format_na_strs
504
505	66x	if (is(final_vals, "RowsVerticalSection")) {
506	20x	final_imods <- indent_mod(final_vals)
507		} else {
508	46x	final_imods <- vapply(final_vals, indent_mod, 1L)
509		}
510	66x	final_imods[names(.indent_mods)] <- .indent_mods
511
512	66x	if (!is.null(.ungroup_stats)) {
513	2x	for (nm in .ungroup_stats) {
514	3x	tmp <- final_vals[[nm]]
515	3x	if (is(tmp, "CellValue")) {
516	1x	tmp <- tmp[[1]]
517	23x	} ## unwrap it
518	3x	final_vals <- insert_replace(final_vals, nm, tmp)
519	3x	stopifnot(all(nzchar(names(final_vals))))
520
521	3x	final_labels <- insert_replace(
522	3x	final_labels,
523	3x	nm,
524	3x	setNames(
525	3x	value_labels(tmp),
526	3x	names(tmp)
527		)
528		)
529	3x	final_formats <- insert_replace(
530	3x	final_formats,
531	3x	nm,
532	3x	setNames(
533	3x	rep(final_formats[nm],
534	3x	length.out = length(tmp)
535		),
536	3x	names(tmp)
537		)
538		)
539	3x	final_format_na_strs <- insert_replace(
540	3x	final_format_na_strs,
541	3x	nm,
542	3x	setNames(
543	3x	rep(final_format_na_strs[nm],
544	3x	length.out = length(tmp)
545		),
546	3x	names(tmp)
547		)
548		)
549	3x	final_imods <- insert_replace(
550	3x	final_imods,
551	3x	nm,
552	3x	setNames(
553	3x	rep(final_imods[nm],
554	3x	length.out = length(tmp)
555		),
556	3x	names(tmp)
557		)
558		)
559		}
560		}
561	66x	rcells <- mapply(
562	66x	function(x, f, l, na_str) {
563	197x	if (is(x, "CellValue")) {
564	65x	obj_label(x) <- l
565	65x	obj_format(x) <- f
566	65x	obj_na_str(x) <- na_str
567		# indent_mod(x) <- im
568	65x	x
569	132x	} else if (.null_ref_cells) {
570	!	non_ref_rcell(x,
571	!	is_ref = .in_ref_col,
572	!	format = f, label = l,
573	!	format_na_str = na_str
574	!	) # , indent_mod = im)
575		} else {
576	132x	rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)
577		}
578		},
579	66x	f = final_formats, x = final_vals,
580	66x	l = final_labels,
581	66x	na_str = final_format_na_strs,
582		# im = final_imods,
583	66x	SIMPLIFY = FALSE
584		)
585	66x	in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)
586		}
587	23x	formals(ret) <- formals(fun)
588	23x	ret
589		}
590
591		insert_replace <- function(x, nm, newvals = x[[nm]]) {
592	15x	i <- match(nm, names(x))
593	15x	if (is.na(i)) {
594	!	stop("name not found")
595		}
596	15x	bef <- if (i > 1) 1:(i - 1) else numeric()
597	15x	aft <- if (i < length(x)) (i + 1):length(x) else numeric()
598	15x	ret <- c(x[bef], newvals, x[aft])
599	15x	names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])
600	15x	ret
601		}
602
603		parser_helper <- function(text, envir = parent.frame(2)) {
604	505x	parse(text = text, keep.source = FALSE)
605		}
606
607		length_w_name <- function(x, .parent_splval) {
608	!	in_rows(length(x),
609	!	.names = value_labels(.parent_splval)
610		)
611		}

1		# paths summary ----
2
3		#' Get a list of table row/column paths
4		#'
5		#' @param x (`VTableTree`)\cr an `rtable` object.
6		#'
7		#' @return A list of paths to each row/column within `x`.
8		#'
9		#' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()]
10		#'
11		#' @examples
12		#' lyt <- basic_table() %>%
13		#' split_cols_by("ARM") %>%
14		#' analyze(c("SEX", "AGE"))
15		#'
16		#' tbl <- build_table(lyt, ex_adsl)
17		#' tbl
18		#'
19		#' row_paths(tbl)
20		#' col_paths(tbl)
21		#'
22		#' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
23		#'
24		#' @rdname make_col_row_df
25		#' @export
26		row_paths <- function(x) {
27	45x	stopifnot(is_rtable(x))
28	45x	make_row_df(x, visible_only = TRUE)$path
29		}
30
31		#' @rdname make_col_row_df
32		#' @export
33		col_paths <- function(x) {
34	2341x	if (!is(coltree(x), "LayoutColTree")) {
35	!	stop("I don't know how to extract the column paths from an object of class ", class(x))
36		}
37	2341x	make_col_df(x, visible_only = TRUE)$path
38		}
39
40		#' Print row/column paths summary
41		#'
42		#' @param x (`VTableTree`)\cr an `rtable` object.
43		#'
44		#' @return A data frame summarizing the row- or column-structure of `x`.
45		#'
46		#' @examplesIf require(dplyr)
47		#' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
48		#'
49		#' lyt <- basic_table() %>%
50		#' split_cols_by("ARM") %>%
51		#' split_cols_by("SEX", split_fun = drop_split_levels) %>%
52		#' analyze(c("AGE", "BMRKR2"))
53		#'
54		#' tbl <- build_table(lyt, ex_adsl_MF)
55		#' tbl
56		#'
57		#' df <- row_paths_summary(tbl)
58		#' df
59		#'
60		#' col_paths_summary(tbl)
61		#'
62		#' # manually constructed table
63		#' tbl2 <- rtable(
64		#' rheader(
65		#' rrow(
66		#' "row 1", rcell("a", colspan = 2),
67		#' rcell("b", colspan = 2)
68		#' ),
69		#' rrow("h2", "a", "b", "c", "d")
70		#' ),
71		#' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
72		#' )
73		#' col_paths_summary(tbl2)
74		#'
75		#' @export
76		row_paths_summary <- function(x) {
77	1x	stopifnot(is_rtable(x))
78
79	1x	if (nrow(x) == 0) {
80	!	return("rowname node_class path\n---------------------\n")
81		}
82
83	1x	pagdf <- make_row_df(x, visible_only = TRUE)
84	1x	row.names(pagdf) <- NULL
85
86	1x	mat <- rbind(
87	1x	c("rowname", "node_class", "path"),
88	1x	t(apply(pagdf, 1, function(xi) {
89	28x	c(
90	28x	indent_string(xi$label, xi$indent),
91	28x	xi$node_class,
92	28x	paste(xi$path, collapse = ", ")
93		)
94		}))
95		)
96
97	1x	txt <- mat_as_string(mat)
98	1x	cat(txt)
99	1x	cat("\n")
100
101	1x	invisible(pagdf[, c("label", "indent", "node_class", "path")])
102		}
103
104		#' @rdname row_paths_summary
105		#' @export
106		col_paths_summary <- function(x) {
107	1x	stopifnot(is_rtable(x))
108
109	1x	pagdf <- make_col_df(x, visible_only = FALSE)
110	1x	row.names(pagdf) <- NULL
111
112	1x	mat <- rbind(
113	1x	c("label", "path"),
114	1x	t(apply(pagdf, 1, function(xi) {
115	6x	c(
116	6x	indent_string(xi$label, floor(length(xi$path) / 2 - 1)),
117	6x	paste(xi$path, collapse = ", ")
118		)
119		}))
120		)
121
122	1x	txt <- mat_as_string(mat)
123	1x	cat(txt)
124	1x	cat("\n")
125
126	1x	invisible(pagdf[, c("label", "path")])
127		}
128
129		# Rows ----
130		# . Summarize Rows ----
131
132		# summarize_row_df <-
133		# function(name,
134		# label,
135		# indent,
136		# depth,
137		# rowtype,
138		# indent_mod,
139		# level) {
140		# data.frame(
141		# name = name,
142		# label = label,
143		# indent = indent,
144		# depth = level,
145		# rowtype = rowtype,
146		# indent_mod = indent_mod,
147		# level = level,
148		# stringsAsFactors = FALSE
149		# )
150		# }
151
152		#' Summarize rows
153		#'
154		#' @inheritParams gen_args
155		#' @param depth (`numeric(1)`)\cr depth.
156		#' @param indent (`numeric(1)`)\cr indent.
157		#'
158		#' @examplesIf require(dplyr)
159		#' library(dplyr)
160		#'
161		#' iris2 <- iris %>%
162		#' group_by(Species) %>%
163		#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
164		#' ungroup()
165		#'
166		#' lyt <- basic_table() %>%
167		#' split_cols_by("Species") %>%
168		#' split_cols_by("group") %>%
169		#' analyze(c("Sepal.Length", "Petal.Width"),
170		#' afun = list_wrap_x(summary),
171		#' format = "xx.xx"
172		#' )
173		#'
174		#' tbl <- build_table(lyt, iris2)
175		#'
176		#' @rdname int_methods
177		setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
178	!	standardGeneric("summarize_rows_inner")
179		})
180
181		#' @rdname int_methods
182		setMethod(
183		"summarize_rows_inner", "TableTree",
184		function(obj, depth = 0, indent = 0) {
185	!	indent <- max(0L, indent + indent_mod(obj))
186
187	!	lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent)
188	!	if (!is.null(lr)) {
189	!	ret <- list(lr)
190		} else {
191	!	ret <- list()
192		}
193
194	!	indent <- indent + (!is.null(lr))
195
196	!	ctab <- content_table(obj)
197	!	if (NROW(ctab)) {
198	!	ct <- summarize_rows_inner(ctab,
199	!	depth = depth,
200	!	indent = indent + indent_mod(ctab)
201		)
202	!	ret <- c(ret, ct)
203	!	indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab))
204		}
205
206	!	kids <- tree_children(obj)
207	!	els <- lapply(tree_children(obj), summarize_rows_inner,
208	!	depth = depth + 1, indent = indent
209		)
210	!	if (!are(kids, "TableRow")) {
211	!	if (!are(kids, "VTableTree")) {
212		## hatchet job of a hack, wrap em just so we can unlist em all at
213		## the same level
214	!	rowinds <- vapply(kids, is, NA, class2 = "TableRow")
215	!	els[rowinds] <- lapply(els[rowinds], function(x) list(x))
216		}
217	!	els <- unlist(els, recursive = FALSE)
218		}
219	!	ret <- c(ret, els)
220	!	ret
221		## df <- do.call(rbind, c(list(lr), list(ct), els))
222
223		## row.names(df) <- NULL
224		## df
225		}
226		)
227
228		# Print Table Structure ----
229
230		#' Summarize table
231		#'
232		#' @param x (`VTableTree`)\cr a table object.
233		#' @param detail (`string`)\cr either `row` or `subtable`.
234		#'
235		#' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`.
236		#'
237		#' @examplesIf require(dplyr)
238		#' library(dplyr)
239		#'
240		#' iris2 <- iris %>%
241		#' group_by(Species) %>%
242		#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
243		#' ungroup()
244		#'
245		#' lyt <- basic_table() %>%
246		#' split_cols_by("Species") %>%
247		#' split_cols_by("group") %>%
248		#' analyze(c("Sepal.Length", "Petal.Width"),
249		#' afun = list_wrap_x(summary),
250		#' format = "xx.xx"
251		#' )
252		#'
253		#' tbl <- build_table(lyt, iris2)
254		#' tbl
255		#'
256		#' row_paths(tbl)
257		#'
258		#' table_structure(tbl)
259		#'
260		#' table_structure(tbl, detail = "row")
261		#'
262		#' @export
263		table_structure <- function(x, detail = c("subtable", "row")) {
264	2x	detail <- match.arg(detail)
265
266	2x	switch(detail,
267	1x	subtable = treestruct(x),
268	1x	row = table_structure_inner(x),
269	!	stop("unsupported level of detail ", detail)
270		)
271		}
272
273		#' @param obj (`VTableTree`)\cr a table object.
274		#' @param depth (`numeric(1)`)\cr depth in tree.
275		#' @param indent (`numeric(1)`)\cr indent.
276		#' @param print_indent (`numeric(1)`)\cr indent for printing.
277		#'
278		#' @rdname int_methods
279		setGeneric(
280		"table_structure_inner",
281		function(obj,
282		depth = 0,
283		indent = 0,
284		print_indent = 0) {
285	70x	standardGeneric("table_structure_inner")
286		}
287		)
288
289		scat <- function(..., indent = 0, newline = TRUE) {
290	101x	txt <- paste(..., collapse = "", sep = "")
291
292	101x	cat(indent_string(txt, indent))
293
294	101x	if (newline) cat("\n")
295		}
296
297		## helper functions
298		obj_visible <- function(x) {
299	50x	x@visible
300		}
301
302		is_empty_labelrow <- function(x) {
303	4x	obj_label(x) == "" && !labelrow_visible(x)
304		}
305
306		is_empty_ElementaryTable <- function(x) {
307	10x	length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x))
308		}
309
310		#' @param object (`VTableTree`)\cr a table object.
311		#'
312		#' @rdname int_methods
313		#' @export
314		setGeneric("str", function(object, ...) {
315	!	standardGeneric("str")
316		})
317
318		#' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike
319		#' the underlying default of `NA`. `NA` is not appropriate for `VTableTree` objects.
320		#'
321		#' @rdname int_methods
322		#' @export
323		setMethod(
324		"str", "VTableTree",
325		function(object, max.level = 3L, ...) {
326	!	utils::str(object, max.level = max.level, ...)
327	!	warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
328	!	"See table_structure(.) for a summary of table struture intended for end users.",
329	!	call. = FALSE
330		)
331	!	invisible(NULL)
332		}
333		)
334
335		#' @inheritParams table_structure_inner
336		#' @rdname int_methods
337		setMethod(
338		"table_structure_inner", "TableTree",
339		function(obj, depth = 0, indent = 0, print_indent = 0) {
340	10x	indent <- indent + indent_mod(obj)
341
342	10x	scat("TableTree: ", "[", obj_name(obj), "] (",
343	10x	obj_label(obj), ")",
344	10x	indent = print_indent
345		)
346
347	10x	table_structure_inner(
348	10x	tt_labelrow(obj), depth, indent,
349	10x	print_indent + 1
350		)
351
352	10x	ctab <- content_table(obj)
353	10x	visible_content <- if (is_empty_ElementaryTable(ctab)) {
354		# scat("content: -", indent = print_indent + 1)
355	4x	FALSE
356		} else {
357	6x	scat("content:", indent = print_indent + 1)
358	6x	table_structure_inner(ctab,
359	6x	depth = depth,
360	6x	indent = indent + indent_mod(ctab),
361	6x	print_indent = print_indent + 2
362		)
363		}
364
365	10x	if (length(tree_children(obj)) == 0) {
366	!	scat("children: - ", indent = print_indent + 1)
367		} else {
368	10x	scat("children: ", indent = print_indent + 1)
369	10x	lapply(tree_children(obj), table_structure_inner,
370	10x	depth = depth + 1,
371	10x	indent = indent + visible_content * (1 + indent_mod(ctab)),
372	10x	print_indent = print_indent + 2
373		)
374		}
375
376	10x	invisible(NULL)
377		}
378		)
379
380		#' @rdname int_methods
381		setMethod(
382		"table_structure_inner", "ElementaryTable",
383		function(obj, depth = 0, indent = 0, print_indent = 0) {
384	15x	scat("ElementaryTable: ", "[", obj_name(obj),
385	15x	"] (", obj_label(obj), ")",
386	15x	indent = print_indent
387		)
388
389	15x	indent <- indent + indent_mod(obj)
390
391	15x	table_structure_inner(
392	15x	tt_labelrow(obj), depth,
393	15x	indent, print_indent + 1
394		)
395
396	15x	if (length(tree_children(obj)) == 0) {
397	!	scat("children: - ", indent = print_indent + 1)
398		} else {
399	15x	scat("children: ", indent = print_indent + 1)
400	15x	lapply(tree_children(obj), table_structure_inner,
401	15x	depth = depth + 1, indent = indent,
402	15x	print_indent = print_indent + 2
403		)
404		}
405
406	15x	invisible(NULL)
407		}
408		)
409
410		#' @rdname int_methods
411		setMethod(
412		"table_structure_inner", "TableRow",
413		function(obj, depth = 0, indent = 0, print_indent = 0) {
414	20x	scat(class(obj), ": ", "[", obj_name(obj), "] (",
415	20x	obj_label(obj), ")",
416	20x	indent = print_indent
417		)
418
419	20x	indent <- indent + indent_mod(obj)
420
421	20x	invisible(NULL)
422		}
423		)
424
425		#' @rdname int_methods
426		setMethod(
427		"table_structure_inner", "LabelRow",
428		function(obj, depth = 0, indent = 0, print_indent = 0) {
429	25x	indent <- indent + indent_mod(obj)
430
431	25x	txtvis <- if (!obj_visible(obj)) " - <not visible>" else ""
432
433	25x	scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
434	25x	txtvis,
435	25x	indent = print_indent
436		)
437
438	25x	obj_visible(obj)
439		}
440		)

1		# as_result_df ------------------------------------------------------------
2		#' Generate a result data frame
3		#'
4		#' Collection of utilities to extract `data.frame` objects from `TableTree` objects.
5		#'
6		#' @inheritParams gen_args
7		#' @param spec (`function`)\cr function that generates the result data frame from a table (`TableTree`).
8		#' It defaults to `NULL`, for standard processing.
9		#' @param expand_colnames (`flag`)\cr when `TRUE`, the result data frame will have expanded column
10		#' names above the usual output. This is useful when the result data frame is used for further processing.
11		#' @param data_format (`string`)\cr the format of the data in the result data frame. It can be one value
12		#' between `"full_precision"` (default), `"strings"`, and `"numeric"`. The last two values show the numeric
13		#' data with the visible precision.
14		#' @param make_ard (`flag`)\cr when `TRUE`, the result data frame will have only one statistic per row.
15		#' @param keep_label_rows (`flag`)\cr when `TRUE`, the result data frame will have all labels
16		#' as they appear in the final table.
17		#' @param simplify (`flag`)\cr when `TRUE`, the result data frame will have only visible labels and
18		#' result columns. Consider showing also label rows with `keep_label_rows = TRUE`. This output can be
19		#' used again to create a `TableTree` object with [df_to_tt()].
20		#' @param ... additional arguments passed to spec-specific result data frame function (`spec`).
21		#'
22		#' @return
23		#' * `as_result_df` returns a result `data.frame`.
24		#'
25		#' @seealso [df_to_tt()] when using `simplify = TRUE` and [formatters::make_row_df()] to have a
26		#' comprehensive view of the hierarchical structure of the rows.
27		#'
28		#' @examples
29		#' lyt <- basic_table() %>%
30		#' split_cols_by("ARM") %>%
31		#' split_rows_by("STRATA1") %>%
32		#' analyze(c("AGE", "BMRKR2"))
33		#'
34		#' tbl <- build_table(lyt, ex_adsl)
35		#' as_result_df(tbl, simplify = TRUE)
36		#'
37		#' @name data.frame_export
38		#' @export
39		as_result_df <- function(tt, spec = NULL,
40		data_format = c("full_precision", "strings", "numeric"),
41		make_ard = FALSE,
42		expand_colnames = FALSE,
43		keep_label_rows = FALSE,
44		simplify = FALSE,
45		...) {
46	24x	data_format <- data_format[[1]]
47	24x	checkmate::assert_class(tt, "VTableTree")
48	24x	checkmate::assert_function(spec, null.ok = TRUE)
49	24x	checkmate::assert_choice(data_format[[1]], choices = eval(formals(as_result_df)[["data_format"]]))
50	24x	checkmate::assert_flag(make_ard)
51	24x	checkmate::assert_flag(expand_colnames)
52	24x	checkmate::assert_flag(keep_label_rows)
53	24x	checkmate::assert_flag(simplify)
54
55	24x	if (nrow(tt) == 0) {
56	2x	return(sanitize_table_struct(tt))
57		}
58
59	22x	if (make_ard) {
60	!	simplify <- FALSE
61	!	expand_colnames <- TRUE
62	!	keep_label_rows <- FALSE
63		}
64
65	22x	if (is.null(spec)) {
66	22x	raw_cvals <- cell_values(tt)
67		## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values
68		## rather than a list of length 1 representing the single row. This is bad but may not be changeable
69		## at this point.
70	22x	if (nrow(tt) == 1 && length(raw_cvals) > 1) {
71	2x	raw_cvals <- list(raw_cvals)
72		}
73
74		# Flatten the list of lists (rows) of cell values into a data frame
75	22x	cellvals <- as.data.frame(do.call(rbind, raw_cvals))
76	22x	row.names(cellvals) <- NULL
77
78	22x	if (nrow(tt) == 1 && ncol(tt) == 1) {
79	5x	colnames(cellvals) <- names(raw_cvals)
80		}
81
82	22x	if (data_format %in% c("strings", "numeric")) {
83		# we keep previous calculations to check the format of the data
84	9x	mf_tt <- matrix_form(tt)
85	9x	mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1]
86	9x	mf_result_chars <- .remove_empty_elements(mf_result_chars)
87	9x	mf_result_numeric <- as.data.frame(
88	9x	.make_numeric_char_mf(mf_result_chars)
89		)
90	9x	mf_result_chars <- as.data.frame(mf_result_chars)
91	9x	if (!setequal(dim(mf_result_numeric), dim(cellvals)) \|\| !setequal(dim(mf_result_chars), dim(cellvals))) {
92	!	stop(
93	!	"The extracted numeric data.frame does not have the same dimension of the",
94	!	" cell values extracted with cell_values(). This is a bug. Please report it."
95	!	) # nocov
96		}
97	9x	if (data_format == "strings") {
98	5x	colnames(mf_result_chars) <- colnames(cellvals)
99	5x	cellvals <- mf_result_chars
100		} else {
101	4x	colnames(mf_result_numeric) <- colnames(cellvals)
102	4x	cellvals <- mf_result_numeric
103		}
104		}
105
106	22x	rdf <- make_row_df(tt)
107	22x	cinfo_df <- col_info(tt)
108	22x	ci_coltree <- coltree(cinfo_df)
109	22x	column_split_names <- .get_column_split_name(ci_coltree) # used only in make_ard
110
111	22x	df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
112		# Removing initial root elements from path (out of the loop -> right maxlen)
113	22x	df$path <- lapply(df$path, .remove_root_elems_from_path,
114	22x	which_root_name = c("root", "rbind_root"),
115	22x	all = TRUE
116		)
117	22x	maxlen <- max(lengths(df$path))
118
119		# Loop for metadata (path and details from make_row_df)
120	22x	metadf <- do.call(
121	22x	rbind.data.frame,
122	22x	lapply(
123	22x	seq_len(NROW(df)),
124	22x	function(ii) {
125	433x	handle_rdf_row(df[ii, ], maxlen = maxlen)
126		}
127		)
128		)
129
130		# Should we keep label rows with NAs instead of values?
131	22x	if (keep_label_rows) {
132	6x	cellvals_mat_struct <- as.data.frame(
133	6x	matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals))
134		)
135	6x	colnames(cellvals_mat_struct) <- colnames(cellvals)
136	6x	cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals
137	6x	ret <- cbind(metadf, cellvals_mat_struct)
138		} else {
139	16x	ret <- cbind(
140	16x	metadf[metadf$node_class != "LabelRow", ],
141	16x	cellvals
142		)
143		}
144
145		# If we want to expand colnames
146	22x	if (expand_colnames) {
147	6x	col_name_structure <- .get_formatted_colnames(clayout(tt))
148	6x	number_of_non_data_cols <- which(colnames(ret) == "node_class")
149	6x	if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
150	!	stop(
151	!	"When expanding colnames structure, we were not able to find the same",
152	!	" number of columns as in the result data frame. This is a bug. Please report it."
153	!	) # nocov
154		}
155
156	6x	buffer_rows_for_colnames <- matrix(
157	6x	rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
158	6x	nrow = NROW(col_name_structure)
159		)
160
161	6x	header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure))
162	6x	colnames(header_colnames_matrix) <- colnames(ret)
163
164	6x	count_row <- NULL
165	6x	if (disp_ccounts(tt)) {
166	3x	ccounts <- col_counts(tt)
167	3x	if (data_format == "strings") {
168	2x	ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ]
169	2x	ccounts <- .remove_empty_elements(ccounts)
170		}
171	3x	count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
172	3x	header_colnames_matrix <- rbind(header_colnames_matrix, count_row)
173		}
174	6x	ret <- rbind(header_colnames_matrix, ret)
175		}
176
177		# ARD part for one stat per row
178	22x	if (make_ard) {
179		# Unnecessary columns
180	!	ret_tmp <- ret[, !colnames(ret) %in% c("row_num", "is_group_summary", "node_class")]
181
182		# Indexes of real columns (visible in the output, but no row names)
183	!	only_col_indexes <- seq(which(colnames(ret_tmp) == "label_name") + 1, ncol(ret_tmp))
184
185		# Core row names
186	!	col_label_rows <- grepl("<only_for_column_*", ret_tmp$avar_name)
187	!	core_row_names <- ret_tmp[!col_label_rows, -only_col_indexes]
188
189		# Moving colnames to rows (flattening)
190	!	ret_w_cols <- NULL
191	!	for (col_i in only_col_indexes) {
192	!	tmp_ret_by_col_i <- cbind(
193	!	group1 = column_split_names[[ret_tmp[, col_i][[1]]]],
194	!	group1_level = ret_tmp[, col_i][[1]],
195		# instead of avar_name row_name label_name ("variable_label" is not present in ARDs)
196	!	setNames(core_row_names, c("variable", "variable_level", "variable_label")), # missing stat_name xxx
197	!	stat = I(setNames(ret_tmp[!col_label_rows, col_i], NULL))
198		)
199
200	!	ret_w_cols <- rbind(ret_w_cols, tmp_ret_by_col_i)
201		}
202
203	!	ret <- ret_w_cols
204		}
205
206		# Simplify the result data frame
207	22x	out <- if (simplify) {
208	6x	.simplify_result_df(ret)
209		} else {
210	16x	ret
211		}
212
213		# take out rownames
214	22x	rownames(out) <- NULL
215		} else {
216		# Applying specs
217	!	out <- spec(tt, ...)
218		}
219
220	22x	out
221		}
222
223		# Helper function to get column split names
224		.get_column_split_name <- function(ci_coltree) {
225		# ci stands for column information
226	126x	if (is(ci_coltree, "LayoutAxisTree")) {
227	46x	kids <- tree_children(ci_coltree)
228	46x	return(unlist(lapply(kids, .get_column_split_name)))
229		}
230	80x	sapply(pos_splits(tree_pos(ci_coltree)), spl_payload)
231		}
232
233		# Function that selects specific outputs from the result data frame
234		.simplify_result_df <- function(df) {
235	6x	col_df <- colnames(df)
236	6x	if (!all(c("label_name", "node_class") %in% col_df)) {
237	!	stop("Please simplify the result data frame only when it has 'label_name' and 'node_class' columns.")
238		}
239	6x	label_names_col <- which(col_df == "label_name")
240	6x	result_cols <- seq(which(col_df == "node_class") + 1, length(col_df))
241
242	6x	df[, c(label_names_col, result_cols)]
243		}
244
245		.remove_empty_elements <- function(char_df) {
246	11x	if (is.null(dim(char_df))) {
247	5x	return(char_df[nzchar(char_df, keepNA = TRUE)])
248		}
249
250	6x	apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)])
251		}
252
253		# Helper function to make the character matrix numeric
254		.make_numeric_char_mf <- function(char_df) {
255	9x	if (is.null(dim(char_df))) {
256	3x	return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+\|\\d+")))
257		}
258
259	6x	ret <- apply(char_df, 2, function(col_i) {
260	27x	lapply(
261	27x	stringi::stri_extract_all(col_i, regex = "\\d+.\\d+\|\\d+"),
262	27x	as.numeric
263		)
264		})
265
266	6x	do.call(cbind, ret)
267		}
268
269		make_result_df_md_colnames <- function(maxlen) {
270	433x	spllen <- floor((maxlen - 2) / 2)
271	433x	ret <- character()
272	433x	if (spllen > 0) {
273	387x	ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_")
274		}
275	433x	ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
276		}
277
278		do_label_row <- function(rdfrow, maxlen) {
279	143x	pth <- rdfrow$path[[1]]
280		# Adjusting for the fact that we have two columns for each split
281	143x	extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2
282
283		# Special cases with hidden labels
284	143x	if (length(pth) %% 2 == 1) {
285	108x	extra_nas_from_splits <- extra_nas_from_splits + 1
286		}
287
288	143x	c(
289	143x	as.list(pth[seq_len(length(pth) - 1)]),
290	143x	as.list(replicate(extra_nas_from_splits, list(NA_character_))),
291	143x	as.list(tail(pth, 1)),
292	143x	list(
293	143x	label_name = rdfrow$label,
294	143x	row_num = rdfrow$abs_rownumber,
295	143x	content = FALSE,
296	143x	node_class = rdfrow$node_class
297		)
298		)
299		}
300
301		do_content_row <- function(rdfrow, maxlen) {
302	36x	pth <- rdfrow$path[[1]]
303	36x	contpos <- which(pth == "@content")
304
305	36x	seq_before <- seq_len(contpos - 1)
306
307	36x	c(
308	36x	as.list(pth[seq_before]),
309	36x	as.list(replicate(maxlen - contpos, list(NA_character_))),
310	36x	list(tail(pth, 1)),
311	36x	list(
312	36x	label_name = rdfrow$label,
313	36x	row_num = rdfrow$abs_rownumber,
314	36x	content = TRUE,
315	36x	node_class = rdfrow$node_class
316		)
317		)
318		}
319
320		do_data_row <- function(rdfrow, maxlen) {
321	254x	pth <- rdfrow$path[[1]]
322	254x	pthlen <- length(pth)
323		## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame
324	254x	if (pthlen %% 2 == 1) {
325	38x	pth <- pth[-1 * (pthlen - 2)]
326		}
327	254x	pthlen_new <- length(pth)
328	33x	if (maxlen == 1) pthlen_new <- 3
329	254x	c(
330	254x	as.list(pth[seq_len(pthlen_new - 2)]),
331	254x	replicate(maxlen - pthlen, list(NA_character_)),
332	254x	as.list(tail(pth, 2)),
333	254x	list(
334	254x	label_name = rdfrow$label,
335	254x	row_num = rdfrow$abs_rownumber,
336	254x	content = FALSE,
337	254x	node_class = rdfrow$node_class
338		)
339		)
340		}
341
342		.remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
343	434x	any_root_paths <- path[1] %in% which_root_name
344	434x	if (any_root_paths) {
345	274x	if (isTRUE(all)) {
346		# Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later)
347	274x	root_indices <- which(path %in% which_root_name)
348	274x	if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
349	!	end_point_root_headers <- which(diff(root_indices) > 1)[1]
350		} else {
351	274x	end_point_root_headers <- length(root_indices)
352		}
353	274x	root_path_to_remove <- seq_len(end_point_root_headers)
354		} else {
355	!	root_path_to_remove <- 1
356		}
357	274x	path <- path[-root_path_to_remove]
358		}
359
360		# Fix for very edge case where we have only root elements
361	434x	if (length(path) == 0) {
362	1x	path <- which_root_name[1]
363		}
364
365	434x	path
366		}
367
368		handle_rdf_row <- function(rdfrow, maxlen) {
369	433x	nclass <- rdfrow$node_class
370
371	433x	ret <- switch(nclass,
372	433x	LabelRow = do_label_row(rdfrow, maxlen),
373	433x	ContentRow = do_content_row(rdfrow, maxlen),
374	433x	DataRow = do_data_row(rdfrow, maxlen),
375	433x	stop("Unrecognized node type in row dataframe, unable to generate result data frame")
376		)
377	433x	setNames(ret, make_result_df_md_colnames(maxlen))
378		}
379
380		# Helper recurrent function to get the column names for the result data frame from the VTableTree
381		.get_formatted_colnames <- function(clyt) {
382	41x	ret <- obj_label(clyt)
383	41x	if (!nzchar(ret)) {
384	6x	ret <- NULL
385		}
386	41x	if (is.null(tree_children(clyt))) {
387	!	return(ret)
388		} else {
389	41x	ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames)))
390	41x	colnames(ret) <- NULL
391	41x	rownames(ret) <- NULL
392	41x	return(ret)
393		}
394		}
395		# path_enriched_df ------------------------------------------------------------
396		#
397		#' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`.
398		#'
399		#' @param path_fun (`function`)\cr function to transform paths into single-string row/column names.
400		#' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to
401		#' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `\|`.
402		#'
403		#' @return
404		#' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by
405		#' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed
406		#' by `path_fun`).
407		#'
408		#' @examples
409		#' lyt <- basic_table() %>%
410		#' split_cols_by("ARM") %>%
411		#' analyze(c("AGE", "BMRKR2"))
412		#'
413		#' tbl <- build_table(lyt, ex_adsl)
414		#' path_enriched_df(tbl)
415		#'
416		#' @export
417		path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
418	3x	rdf <- make_row_df(tt)
419	3x	cdf <- make_col_df(tt)
420	3x	cvs <- as.data.frame(do.call(rbind, cell_values(tt)))
421	3x	cvs <- as.data.frame(lapply(cvs, value_fun))
422	3x	row.names(cvs) <- NULL
423	3x	colnames(cvs) <- path_fun(cdf$path)
424	3x	preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path)
425	3x	cbind.data.frame(row_path = preppaths, cvs)
426		}
427
428		.collapse_char <- "\|"
429		.collapse_char_esc <- "\\\|"
430
431		collapse_path <- function(paths) {
432	196x	if (is.list(paths)) {
433	6x	return(vapply(paths, collapse_path, ""))
434		}
435	190x	paste(paths, collapse = .collapse_char)
436		}
437
438		collapse_values <- function(colvals) {
439	13x	if (!is.list(colvals)) { ## \|\| all(vapply(colvals, length, 1L) == 1))
440	!	return(colvals)
441	13x	} else if (all(vapply(colvals, length, 1L) == 1)) {
442	1x	return(unlist(colvals))
443		}
444	12x	vapply(colvals, paste, "", collapse = .collapse_char)
445		}

1		#' Score functions for sorting `TableTrees`
2		#'
3		#' @inheritParams gen_args
4		#'
5		#' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting.
6		#'
7		#' @export
8		#' @rdname score_funs
9		cont_n_allcols <- function(tt) {
10	6x	ctab <- content_table(tt)
11	6x	if (NROW(ctab) == 0) {
12	2x	stop(
13	2x	"cont_n_allcols score function used at subtable [",
14	2x	obj_name(tt), "] that has no content table."
15		)
16		}
17	4x	sum(sapply(
18	4x	row_values(tree_children(ctab)[[1]]),
19	4x	function(cv) cv[1]
20		))
21		}
22
23		#' @param j (`numeric(1)`)\cr index of column used for scoring.
24		#'
25		#' @seealso For examples and details, please read the documentation for [sort_at_path()] and the
26		#' [Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)
27		#' vignette.
28		#'
29		#' @export
30		#' @rdname score_funs
31		cont_n_onecol <- function(j) {
32	2x	function(tt) {
33	6x	ctab <- content_table(tt)
34	6x	if (NROW(ctab) == 0) {
35	2x	stop(
36	2x	"cont_n_allcols score function used at subtable [",
37	2x	obj_name(tt), "] that has no content table."
38		)
39		}
40	4x	row_values(tree_children(ctab)[[1]])[[j]][1]
41		}
42		}
43
44		#' Sorting a table at a specific path
45		#'
46		#' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.
47		#'
48		#' @inheritParams gen_args
49		#' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position
50		#' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value
51		#' to be sorted.
52		#' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If
53		#' unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are
54		#' characters.
55		#' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to
56		#' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores
57		#' should be placed in the order.
58		#' @param .prev_path (`character`)\cr internal detail, do not set manually.
59		#'
60		#' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done
61		#' at `path`.
62		#'
63		#' @details
64		#' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"`
65		#' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting
66		#' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting
67		#' operations.
68		#'
69		#' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus
70		#' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper
71		#' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare
72		#' it, which we encourage users to avoid.
73		#'
74		#' `path` can include the "wildcard" `""` as a step, which translates roughly to any* node/branching element and means
75		#' that each child at that step will be separately sorted based on `scorefun` and the remaining `path` entries. This
76		#' can occur multiple times in a path.
77		#'
78		#' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by
79		#' [formatters::make_row_df()] with the `visible_only` argument set to `FALSE`. It can also be inferred from the
80		#' summary given by [table_structure()].
81		#'
82		#' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related
83		#' vignette
84		#' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html))
85		#' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also
86		#' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and
87		#' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is
88		#' commonly produced by calling one of the various [analyze()] instances.
89		#'
90		#' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows
91		#' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some
92		#' useful descriptor and accessor functions (coming from related vignette):
93		#' - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values.
94		#' - [formatters::obj_name()] - Retrieves the name of an object. Note this can differ from the label that is
95		#' displayed (if any is) when printing.
96		#' - [formatters::obj_label()] - Retrieves the display label of an object. Note this can differ from the name that
97		#' appears in the path.
98		#' - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows).
99		#' - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix
100		#' thereof, though that should not happen in practice).
101		#'
102		#' @seealso
103		#' * Score functions [cont_n_allcols()] and [cont_n_onecol()].
104		#' * [formatters::make_row_df()] and [table_structure()] for pathing information.
105		#' * [tt_at_path()] to select a table's (sub)structure at a given path.
106		#'
107		#' @examples
108		#' # Creating a table to sort
109		#'
110		#' # Function that gives two statistics per table-tree "leaf"
111		#' more_analysis_fnc <- function(x) {
112		#' in_rows(
113		#' "median" = median(x),
114		#' "mean" = mean(x),
115		#' .formats = "xx.x"
116		#' )
117		#' }
118		#'
119		#' # Main layout of the table
120		#' raw_lyt <- basic_table() %>%
121		#' split_cols_by("ARM") %>%
122		#' split_rows_by(
123		#' "RACE",
124		#' split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
125		#' ) %>%
126		#' summarize_row_groups() %>%
127		#' split_rows_by("STRATA1") %>%
128		#' summarize_row_groups() %>%
129		#' analyze("AGE", afun = more_analysis_fnc)
130		#'
131		#' # Creating the table and pruning empty and NAs
132		#' tbl <- build_table(raw_lyt, DM) %>%
133		#' prune_table()
134		#'
135		#' # Peek at the table structure to understand how it is built
136		#' table_structure(tbl)
137		#'
138		#' # Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for
139		#' # the ASIAN group/row-split. This uses content_table() accessor function as it
140		#' # is a "ContentRow". In this case, we also base our sorting only on the second column.
141		#' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
142		#'
143		#' # Custom scoring function that is working on "DataRow"s
144		#' scorefun <- function(tt) {
145		#' # Here we could use browser()
146		#' sum(unlist(row_values(tt))) # Different accessor function
147		#' }
148		#' # Sorting mean and median for all the AGE leaves!
149		#' sort_at_path(tbl, c("RACE", "", "STRATA1", "", "AGE"), scorefun)
150		#'
151		#' @export
152		sort_at_path <- function(tt,
153		path,
154		scorefun,
155		decreasing = NA,
156		na.pos = c("omit", "last", "first"),
157		.prev_path = character()) {
158	35x	if (NROW(tt) == 0) {
159	1x	return(tt)
160		}
161
162		## XXX hacky fix this!!!
163		## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior
164	34x	if (path[1] == "root") {
165		## always remove first root element but only add it to
166		## .prev_path (used for error reporting) if it actually matched the name
167	1x	if (obj_name(tt) == "root") {
168	1x	.prev_path <- c(.prev_path, path[1])
169		}
170	1x	path <- path[-1]
171		}
172	34x	if (identical(obj_name(tt), path[1])) {
173	1x	.prev_path <- c(.prev_path, path[1])
174	1x	path <- path[-1]
175		}
176
177	34x	curpath <- path
178	34x	subtree <- tt
179	34x	backpath <- c()
180	34x	count <- 0
181	34x	while (length(curpath) > 0) {
182	40x	curname <- curpath[1]
183	40x	oldkids <- tree_children(subtree)
184		## we sort each child separately based on the score function
185		## and the remaining path
186	40x	if (curname == "*") {
187	7x	oldnames <- vapply(oldkids, obj_name, "")
188	7x	newkids <- lapply(
189	7x	seq_along(oldkids),
190	7x	function(i) {
191	27x	sort_at_path(oldkids[[i]],
192	27x	path = curpath[-1],
193	27x	scorefun = scorefun,
194	27x	decreasing = decreasing,
195	27x	na.pos = na.pos,
196		## its ok to modify the "path" here because its only ever used for
197		## informative error reporting.
198	27x	.prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
199		)
200		}
201		)
202	4x	names(newkids) <- oldnames
203	4x	newtab <- subtree
204	4x	tree_children(newtab) <- newkids
205	4x	if (length(backpath) > 0) {
206	3x	ret <- recursive_replace(tt, backpath, value = newtab)
207		} else {
208	1x	ret <- newtab
209		}
210	4x	return(ret)
211	33x	} else if (!(curname %in% names(oldkids))) {
212	1x	stop(
213	1x	"Unable to find child(ren) '",
214	1x	curname, "'\n\t occurred at path: ",
215	1x	paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),
216	1x	"\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",
217	1x	"'table_structure(obj)' to explore valid paths."
218		)
219		}
220	32x	subtree <- tree_children(subtree)[[curname]]
221	32x	backpath <- c(backpath, curpath[1])
222	32x	curpath <- curpath[-1]
223	32x	count <- count + 1
224		}
225	26x	real_backpath <- path[seq_len(count)]
226
227	26x	na.pos <- match.arg(na.pos)
228		## subtree <- tt_at_path(tt, path)
229	26x	kids <- tree_children(subtree)
230		## relax this to allow character "scores"
231		## scores <- vapply(kids, scorefun, NA_real_)
232	26x	scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e))
233	26x	errs <- which(vapply(scores, is, class2 = "error", TRUE))
234	26x	if (length(errs) > 0) {
235	2x	stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
236	2x	"First error: ", scores[[errs[1]]]$message,
237	2x	"\n\toccurred at path: ",
238	2x	paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "),
239	2x	call. = FALSE
240		)
241		} else {
242	24x	scores <- unlist(scores)
243		}
244	24x	if (!is.null(dim(scores)) \|\| length(scores) != length(kids)) {
245	!	stop(
246	!	"Score function does not appear to have return exactly one ",
247	!	"scalar value per child"
248		)
249		}
250	24x	if (is.na(decreasing)) {
251	8x	decreasing <- if (is.character(scores)) FALSE else TRUE
252		}
253	24x	ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing)
254	24x	newkids <- kids[ord]
255	24x	if (anyNA(scores) && na.pos == "omit") { # we did na last here
256	!	newkids <- head(newkids, -1 * sum(is.na(scores)))
257		}
258
259	24x	newtree <- subtree
260	24x	tree_children(newtree) <- newkids
261	24x	tt_at_path(tt, path) <- newtree
262	24x	tt
263		}

1		#' Variable associated with a split
2		#'
3		#' This function is intended for use when writing custom splitting logic. In cases where the split is associated with
4		#' a single variable, the name of that variable will be returned. At time of writing this includes splits generated
5		#' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()],
6		#' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives.
7		#'
8		#' @param spl (`VarLevelSplit`)\cr the split object.
9		#'
10		#' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised.
11		#'
12		#' @export
13		#' @seealso \code{\link{make_split_fun}}
14	2x	setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))
15
16		#' @rdname spl_variable
17		#' @export
18	1x	setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))
19
20		#' @rdname spl_variable
21		#' @export
22	!	setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))
23
24		#' @rdname spl_variable
25		#' @export
26	!	setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))
27
28		#' @rdname spl_variable
29		#' @export
30		setMethod(
31		"spl_variable", "Split",
32	1x	function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
33		)
34
35		in_col_split <- function(spl_ctx) {
36	!	identical(
37	!	names(spl_ctx),
38	!	names(context_df_row(cinfo = NULL))
39		)
40		}
41
42		assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
43	45x	msg_2_append <- ""
44	45x	if (!is.null(component)) {
45	33x	msg_2_append <- paste0(
46	33x	"Invalid split function constructed by upstream call to ",
47	33x	"make_split_fun. Problem source: ",
48	33x	component, " argument."
49		)
50		}
51	45x	if (!(nm %in% names(pinfo))) {
52	!	stop(
53	!	"Split result does not have required element: ", nm, ".",
54	!	msg_2_append
55		)
56		}
57	45x	if (!is.null(len) && length(pinfo[[nm]]) != len) {
58	!	stop(
59	!	"Split result element ", nm, " does not have required length ", len, ".",
60	!	msg_2_append
61		)
62		}
63	45x	TRUE
64		}
65
66		validate_split_result <- function(pinfo, component = NULL) {
67	15x	assert_splres_element(pinfo, "datasplit", component = component)
68	15x	len <- length(pinfo$datasplit)
69	15x	assert_splres_element(pinfo, "values", len, component = component)
70	15x	assert_splres_element(pinfo, "labels", len, component = component)
71	15x	TRUE
72		}
73
74		#' Construct split result object
75		#'
76		#' These functions can be used to create or add to a split result in functions which implement core splitting or
77		#' post-processing within a custom split function.
78		#'
79		#' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet.
80		#' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split.
81		#' @param labels (`character`)\cr the labels associated with each facet.
82		#' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to
83		#' analysis functions applied within the facet.
84		#' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,
85		#' created with `quote()`) to be used during column subsetting.
86		#'
87		#' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and
88		#' `labels`, which are the same length and correspond to each other element-wise.
89		#'
90		#' @details
91		#' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables
92		#' internals expect it, most of which are not relevant to end users.
93		#'
94		#' @examples
95		#' splres <- make_split_result(
96		#' values = c("hi", "lo"),
97		#' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),
98		#' labels = c("more data", "less data"),
99		#' subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))
100		#' )
101		#'
102		#' splres2 <- add_to_split_result(splres,
103		#' values = "med",
104		#' datasplit = list(med = mtcars[1:20, ]),
105		#' labels = "kinda some data",
106		#' subset_exprs = quote(seq_along(wt) <= 20)
107		#' )
108		#'
109		#' @family make_custom_split
110		#' @rdname make_split_result
111		#' @export
112		#' @family make_custom_split
113		make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
114	9x	if (length(values) == 1 && is(datasplit, "data.frame")) {
115	!	datasplit <- list(datasplit)
116		}
117	9x	ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)
118	9x	if (!is.null(extras)) {
119	!	ret$extras <- extras
120		}
121	9x	.fixupvals(ret)
122		}
123
124		#' @param splres (`list`)\cr a list representing the result of splitting.
125		#'
126		#' @rdname make_split_result
127		#' @export
128		add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
129	4x	validate_split_result(splres)
130	4x	newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))
131	4x	ret <- lapply(
132	4x	names(splres),
133	4x	function(nm) c(splres[[nm]], newstuff[[nm]])
134		)
135	4x	names(ret) <- names(splres)
136	4x	.fixupvals(ret)
137		}
138
139
140	13x	.can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
141
142		#' Create a custom splitting function
143		#'
144		#' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that
145		#' should split via `core_split`. They will be called on the data in the order they appear in the list.
146		#' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that
147		#' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior
148		#' cannot be used in column splits.
149		#' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting.
150		#'
151		#' @details
152		#' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process:
153		#'
154		#' 1. Pre-processing of the incoming data to be split.
155		#' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets.
156		#' 3. Post-processing operations on the set of facets (groups) generated by the split.
157		#'
158		#' This function provides an interface to create custom split functions by implementing and specifying sets of
159		#' operations in each of those classes of customization independently.
160		#'
161		#' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept
162		#' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame.
163		#' This modified data frame must contain all columns present in the incoming data frame, but can add columns if
164		#' necessary (though we note that these new columns cannot be used in the layout as split or analysis variables,
165		#' because they will not be present when validity checking is done).
166		#'
167		#' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones
168		#' or to reorder levels based on observed counts, etc.
169		#'
170		#' Core splitting functions override the fundamental
171		#' splitting procedure, and are only necessary in rare cases. These
172		#' must accept `spl`, `df`, `vals`, `labels`, and can optionally
173		#' accept `.spl_context`. They should return a split result object
174		#' constructed via `make_split_result()`.
175		#'
176		#' In particular, if the custom split function will be used in
177		#' column space, subsetting expressions (e.g., as returned by
178		#' `quote()` or `bquote` must be provided, while they are
179		#' optional (and largely ignored, currently) in row space.
180		#'
181		#'
182		#' Post-processing functions (3) must accept the result of the core split as their first argument (which can be
183		#' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a
184		#' modified version of the same structure specified above for core splitting.
185		#'
186		#' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied
187		#' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively).
188		#'
189		#' @return A custom function that can be used as a split function.
190		#'
191		#' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do.
192		#'
193		#' @examples
194		#' mysplitfun <- make_split_fun(
195		#' pre = list(drop_facet_levels),
196		#' post = list(add_overall_facet("ALL", "All Arms"))
197		#' )
198		#'
199		#' basic_table(show_colcounts = TRUE) %>%
200		#' split_cols_by("ARM", split_fun = mysplitfun) %>%
201		#' analyze("AGE") %>%
202		#' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
203		#'
204		#' ## post (and pre) arguments can take multiple functions, here
205		#' ## we add an overall facet and the reorder the facets
206		#' reorder_facets <- function(splret, spl, fulldf, ...) {
207		#' ord <- order(names(splret$values))
208		#' make_split_result(
209		#' splret$values[ord],
210		#' splret$datasplit[ord],
211		#' splret$labels[ord]
212		#' )
213		#' }
214		#'
215		#' mysplitfun2 <- make_split_fun(
216		#' pre = list(drop_facet_levels),
217		#' post = list(
218		#' add_overall_facet("ALL", "All Arms"),
219		#' reorder_facets
220		#' )
221		#' )
222		#' basic_table(show_colcounts = TRUE) %>%
223		#' split_cols_by("ARM", split_fun = mysplitfun2) %>%
224		#' analyze("AGE") %>%
225		#' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
226		#'
227		#' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
228		#' make_split_result(c("stupid", "silly"),
229		#' datasplit = list(df[1:10, ], df[11:30, ]),
230		#' labels = c("first 10", "second 20")
231		#' )
232		#' }
233		#'
234		#' dumb_30_facet <- add_combo_facet("dumb",
235		#' label = "thirty patients",
236		#' levels = c("stupid", "silly")
237		#' )
238		#' nonsense_splfun <- make_split_fun(
239		#' core_split = very_stupid_core,
240		#' post = list(dumb_30_facet)
241		#' )
242		#'
243		#' ## recall core split overriding is not supported in column space
244		#' ## currently, but we can see it in action in row space
245		#'
246		#' lyt_silly <- basic_table() %>%
247		#' split_rows_by("ARM", split_fun = nonsense_splfun) %>%
248		#' summarize_row_groups() %>%
249		#' analyze("AGE")
250		#' silly_table <- build_table(lyt_silly, DM)
251		#' silly_table
252		#'
253		#' @family make_custom_split
254		#' @export
255		make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
256	7x	function(df,
257	7x	spl,
258	7x	vals = NULL,
259	7x	labels = NULL,
260	7x	trim = FALSE,
261	7x	.spl_context) {
262	11x	orig_columns <- names(df)
263	11x	for (pre_fn in pre) {
264	5x	if (.can_take_spl_context(pre_fn)) {
265	5x	df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context)
266		} else {
267	!	df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels)
268		}
269	3x	if (!is(df, "data.frame")) {
270	!	stop(
271	!	"Error in custom split function, pre-split step did not return a data.frame. ",
272	!	"See upstream call to make_split_fun for original source of error."
273		)
274		}
275		}
276
277	9x	if (!all(orig_columns %in% names(df))) {
278	!	stop(
279	!	"Preprocessing functions(s) in custom split function removed a column from the incoming data.",
280	!	" This is not supported. See upstread make_split_fun call (pre argument) for original source of error."
281		)
282		}
283
284	9x	if (is.null(core_split)) {
285	7x	ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)
286		} else {
287	2x	ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)
288	2x	validate_split_result(ret, component = "core_split")
289		}
290
291	9x	for (post_fn in post) {
292	8x	if (.can_take_spl_context(post_fn)) {
293	8x	ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df)
294		} else {
295	!	ret <- post_fn(ret, spl = spl, fulldf = df)
296		}
297		}
298	9x	validate_split_result(ret, "post")
299	9x	ret
300		}
301		}
302
303		#' Add a combination facet in post-processing
304		#'
305		#' Add a combination facet during the post-processing stage in a custom split fun.
306		#'
307		#' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.).
308		#' @param label (`string`)\cr label for the resulting facet.
309		#' @param levels (`character`)\cr vector of levels to combine within the resulting facet.
310		#' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet.
311		#'
312		#' @details
313		#' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for
314		#' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data
315		#' that appears in both will be duplicated.
316		#'
317		#' @return A function which can be used within the `post` argument in [make_split_fun()].
318		#'
319		#' @seealso [make_split_fun()]
320		#'
321		#' @examples
322		#' mysplfun <- make_split_fun(post = list(
323		#' add_combo_facet("A_B",
324		#' label = "Arms A+B",
325		#' levels = c("A: Drug X", "B: Placebo")
326		#' ),
327		#' add_overall_facet("ALL", label = "All Arms")
328		#' ))
329		#'
330		#' lyt <- basic_table(show_colcounts = TRUE) %>%
331		#' split_cols_by("ARM", split_fun = mysplfun) %>%
332		#' analyze("AGE")
333		#'
334		#' tbl <- build_table(lyt, DM)
335		#'
336		#' @family make_custom_split
337		#' @export
338		add_combo_facet <- function(name, label = name, levels, extra = list()) {
339	3x	function(ret, spl, .spl_context, fulldf) {
340	4x	if (is(levels, "AllLevelsSentinel")) {
341	1x	subexpr <- expression(TRUE)
342	1x	datpart <- list(fulldf)
343		} else {
344	3x	subexpr <- .combine_value_exprs(ret$values[levels])
345	3x	datpart <- list(do.call(rbind, ret$datasplit[levels]))
346		}
347
348
349	4x	val <- LevelComboSplitValue(
350	4x	val = name, extr = extra, combolevels = levels, label = label,
351	4x	sub_expr = subexpr
352		)
353	4x	add_to_split_result(ret,
354	4x	values = list(val), labels = label,
355	4x	datasplit = datpart
356		)
357		}
358		}
359
360		.combine_value_exprs <- function(val_lst, spl) {
361	3x	exprs <- lapply(val_lst, value_expr)
362	3x	nulls <- vapply(exprs, is.null, TRUE)
363	3x	if (all(nulls)) {
364	1x	return(NULL) # default behavior all the way down the line, no need to do anything.
365	2x	} else if (any(nulls)) {
366	!	exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))
367		}
368	2x	Reduce(.or_combine_exprs, exprs)
369		}
370
371		## no NULLS coming in here, everything has been populated
372		## by either custom subsetting expressions or the result of make_subset_expr(spl, val)
373		.or_combine_exprs <- function(ex1, ex2) {
374	2x	if (identical(ex1, expression(FALSE))) {
375	!	return(ex2)
376	2x	} else if (identical(ex2, expression(FALSE))) {
377	!	return(ex1)
378	2x	} else if (identical(ex1, expression(TRUE)) \|\| identical(ex2, expression(TRUE))) {
379	!	return(TRUE)
380		}
381	2x	as.expression(bquote((.(a)) \| .(b), list(a = ex1[[1]], b = ex2[[1]])))
382		}
383
384		#' @rdname add_combo_facet
385		#' @export
386		add_overall_facet <- function(name, label, extra = list()) {
387	1x	add_combo_facet(
388	1x	name = name, label = label, levels = select_all_levels,
389	1x	extra = extra
390		)
391		}
392
393		#' Trim levels of another variable from each facet (post-processing split step)
394		#'
395		#' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet.
396		#'
397		#' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`.
398		#'
399		#' @seealso [make_split_fun()]
400		#'
401		#' @family make_custom_split
402		#' @export
403		trim_levels_in_facets <- function(innervar) {
404	1x	function(ret, ...) {
405	1x	for (var in innervar) {
406	1x	ret$datasplit <- lapply(ret$datasplit, function(df) {
407	2x	df[[var]] <- factor(df[[var]])
408	2x	df
409		})
410		}
411	1x	ret
412		}
413		}
414
415		#' Pre-processing function for use in `make_split_fun`
416		#'
417		#' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called
418		#' directly by end users.
419		#'
420		#' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet.
421		#' @param spl (`VarLevelSplit`)\cr the split.
422		#' @param ... additional parameters passed internally.
423		#'
424		#' @seealso [make_split_fun()]
425		#'
426		#' @family make_custom_split
427		#' @export
428		drop_facet_levels <- function(df, spl, ...) {
429	2x	if (!is(spl, "VarLevelSplit") \|\| is.na(spl_payload(spl))) {
430	!	stop("Unable to determine faceting variable in drop_facet_levels application.")
431		}
432	2x	var <- spl_payload(spl)
433	2x	df[[var]] <- factor(df[[var]])
434	2x	df
435		}

1		treestruct <- function(obj, ind = 0L) {
2	19x	nc <- ncol(obj)
3	19x	cat(rep(" ", times = ind),
4	19x	sprintf("[%s] %s", class(obj), obj_name(obj)),
5	19x	sep = ""
6		)
7	19x	if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
8	6x	crows <- nrow(content_table(obj))
9	6x	ccols <- if (crows == 0) 0 else nc
10	6x	cat(sprintf(
11	6x	" [cont: %d x %d]",
12	6x	crows, ccols
13		))
14		}
15	19x	if (is(obj, "VTableTree") && length(tree_children(obj))) {
16	19x	kids <- tree_children(obj)
17	19x	if (are(kids, "TableRow")) {
18	9x	cat(sprintf(
19	9x	" (%d x %d)\n",
20	9x	length(kids), nc
21		))
22		} else {
23	10x	cat("\n")
24	10x	lapply(kids, treestruct, ind = ind + 1)
25		}
26		}
27	19x	invisible(NULL)
28		}
29
30		setGeneric(
31		"ploads_to_str",
32	103x	function(x, collapse = ":") standardGeneric("ploads_to_str")
33		)
34
35		setMethod(
36		"ploads_to_str", "Split",
37		function(x, collapse = ":") {
38	52x	paste(sapply(spl_payload(x), ploads_to_str),
39	52x	collapse = collapse
40		)
41		}
42		)
43
44		setMethod(
45		"ploads_to_str", "CompoundSplit",
46		function(x, collapse = ":") {
47	6x	paste(sapply(spl_payload(x), ploads_to_str),
48	6x	collapse = collapse
49		)
50		}
51		)
52
53		setMethod(
54		"ploads_to_str", "list",
55		function(x, collapse = ":") {
56	!	stop("Please contact the maintainer")
57		}
58		)
59
60		setMethod(
61		"ploads_to_str", "SplitVector",
62		function(x, collapse = ":") {
63	8x	sapply(x, ploads_to_str)
64		}
65		)
66
67		setMethod(
68		"ploads_to_str", "ANY",
69		function(x, collapse = ":") {
70	37x	paste(x)
71		}
72		)
73
74	47x	setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))
75
76		setMethod(
77		"payloadmsg", "VarLevelSplit",
78		function(spl) {
79	45x	spl_payload(spl)
80		}
81		)
82
83		setMethod(
84		"payloadmsg", "MultiVarSplit",
85	2x	function(spl) "var"
86		)
87
88		setMethod(
89		"payloadmsg", "VarLevWBaselineSplit",
90		function(spl) {
91	!	paste0(
92	!	spl_payload(spl), "[bsl ",
93	!	spl@ref_group_value, # XXX XXX
94		"]"
95		)
96		}
97		)
98
99		setMethod(
100		"payloadmsg", "ManualSplit",
101	!	function(spl) "mnl"
102		)
103
104		setMethod(
105		"payloadmsg", "AllSplit",
106	!	function(spl) "all"
107		)
108
109		setMethod(
110		"payloadmsg", "ANY",
111		function(spl) {
112	!	warning("don't know how to make payload print message for Split of class", class(spl))
113	!	"XXX"
114		}
115		)
116
117		spldesc <- function(spl, value = "") {
118	32x	value <- rawvalues(value)
119	32x	payloadmsg <- payloadmsg(spl)
120	32x	format <- "%s (%s)"
121	32x	sprintf(
122	32x	format,
123	32x	value,
124	32x	payloadmsg
125		)
126		}
127
128		layoutmsg <- function(obj) {
129		## if(!is(obj, "VLayoutNode"))
130		## stop("how did a non layoutnode object get in docatlayout??")
131
132	28x	pos <- tree_pos(obj)
133	28x	spllst <- pos_splits(pos)
134	28x	spvallst <- pos_splvals(pos)
135	28x	if (is(obj, "LayoutAxisTree")) {
136	12x	kids <- tree_children(obj)
137	12x	return(unlist(lapply(kids, layoutmsg)))
138		}
139
140	16x	msg <- paste(
141	16x	collapse = " -> ",
142	16x	mapply(spldesc,
143	16x	spl = spllst,
144	16x	value = spvallst
145		)
146		)
147	16x	msg
148		}
149
150		setMethod(
151		"show", "LayoutAxisTree",
152		function(object) {
153	2x	msg <- layoutmsg(object)
154	2x	cat(msg, "\n")
155	2x	invisible(object)
156		}
157		)
158
159
160		#' Display column tree structure
161		#'
162		#' Displays the tree structure of the columns of a
163		#' table or column structure object.
164		#'
165		#' @inheritParams gen_args
166		#'
167		#' @return Nothing, called for its side effect of displaying
168		#' a summary to the terminal.
169		#'
170		#' @examples
171		#' lyt <- basic_table() %>%
172		#' split_cols_by("ARM") %>%
173		#' split_cols_by("STRATA1") %>%
174		#' split_cols_by("SEX", nested = FALSE) %>%
175		#' analyze("AGE")
176		#'
177		#' tbl <- build_table(lyt, ex_adsl)
178		#' coltree_structure(tbl)
179		#' @export
180		coltree_structure <- function(obj) {
181	1x	ctree <- coltree(obj)
182	1x	cat(layoutmsg2(ctree))
183		}
184
185		lastposmsg <- function(pos) {
186	6x	spls <- pos_splits(pos)
187	6x	splvals <- value_names(pos_splvals(pos))
188	6x	indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "),
189	6x	spl = spls,
190	6x	valnm = splvals,
191	6x	SIMPLIFY = FALSE
192		))
193	6x	paste(indiv_msgs, collapse = " -> ")
194		}
195
196		layoutmsg2 <- function(obj, level = 1) {
197	7x	nm <- obj_name(obj)
198	7x	pos <- tree_pos(obj)
199	7x	nopos <- identical(pos, EmptyTreePos)
200
201	7x	msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
202	7x	if (is(obj, "LayoutAxisTree")) {
203	3x	kids <- tree_children(obj)
204	3x	msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1)))
205		}
206	7x	msg
207		}
208
209	46x	setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))
210
211		setMethod(
212		"spltype_abbrev", "VarLevelSplit",
213	4x	function(obj) "lvls"
214		)
215
216		setMethod(
217		"spltype_abbrev", "VarLevWBaselineSplit",
218	5x	function(obj) paste("ref_group", obj@ref_group_value)
219		)
220
221		setMethod(
222		"spltype_abbrev", "MultiVarSplit",
223	!	function(obj) "vars"
224		)
225
226		setMethod(
227		"spltype_abbrev", "VarStaticCutSplit",
228	10x	function(obj) "scut"
229		)
230
231		setMethod(
232		"spltype_abbrev", "VarDynCutSplit",
233	5x	function(obj) "dcut"
234		)
235		setMethod(
236		"spltype_abbrev", "AllSplit",
237	15x	function(obj) "all obs"
238		)
239		## setMethod("spltype_abbrev", "NULLSplit",
240		## function(obj) "no obs")
241
242		setMethod(
243		"spltype_abbrev", "AnalyzeVarSplit",
244	1x	function(obj) " analysis "
245		)
246
247		setMethod(
248		"spltype_abbrev", "CompoundSplit",
249	!	function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
250		)
251
252		setMethod(
253		"spltype_abbrev", "AnalyzeMultiVars",
254	6x	function(obj) " multivar analysis "
255		)
256		setMethod(
257		"spltype_abbrev", "AnalyzeColVarSplit",
258	!	function(obj) " col-var analysis "
259		)
260
261		docat_splitvec <- function(object, indent = 0) {
262	8x	if (indent > 0) {
263	!	cat(rep(" ", times = indent), sep = "")
264		}
265	8x	if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
266	!	tab <- object[[1]]
267	!	msg <- sprintf(
268	!	"A Pre-Existing Table [%d x %d]",
269	!	nrow(tab), ncol(tab)
270		)
271		} else {
272	8x	plds <- ploads_to_str(object) ## lapply(object, spl_payload))
273
274	8x	tabbrev <- sapply(object, spltype_abbrev)
275	8x	msg <- paste(
276	8x	collapse = " -> ",
277	8x	paste0(plds, " (", tabbrev, ")")
278		)
279		}
280	8x	cat(msg, "\n")
281		}
282
283		setMethod(
284		"show", "SplitVector",
285		function(object) {
286	1x	cat("A SplitVector Pre-defining a Tree Structure\n\n")
287	1x	docat_splitvec(object)
288	1x	cat("\n")
289	1x	invisible(object)
290		}
291		)
292
293		docat_predataxis <- function(object, indent = 0) {
294	6x	lapply(object, docat_splitvec)
295		}
296
297		setMethod(
298		"show", "PreDataColLayout",
299		function(object) {
300	1x	cat("A Pre-data Column Layout Object\n\n")
301	1x	docat_predataxis(object)
302	1x	invisible(object)
303		}
304		)
305
306		setMethod(
307		"show", "PreDataRowLayout",
308		function(object) {
309	1x	cat("A Pre-data Row Layout Object\n\n")
310	1x	docat_predataxis(object)
311	1x	invisible(object)
312		}
313		)
314
315		setMethod(
316		"show", "PreDataTableLayouts",
317		function(object) {
318	2x	cat("A Pre-data Table Layout\n")
319	2x	cat("\nColumn-Split Structure:\n")
320	2x	docat_predataxis(object@col_layout)
321	2x	cat("\nRow-Split Structure:\n")
322	2x	docat_predataxis(object@row_layout)
323	2x	cat("\n")
324	2x	invisible(object)
325		}
326		)
327
328		setMethod(
329		"show", "InstantiatedColumnInfo",
330		function(object) {
331	2x	layoutmsg <- layoutmsg(coltree(object))
332	2x	cat("An InstantiatedColumnInfo object",
333	2x	"Columns:",
334	2x	layoutmsg,
335	2x	if (disp_ccounts(object)) {
336	2x	paste(
337	2x	"ColumnCounts:\n",
338	2x	paste(col_counts(object),
339	2x	collapse = ", "
340		)
341		)
342		},
343		"",
344	2x	sep = "\n"
345		)
346	2x	invisible(object)
347		}
348		)
349
350		#' @rdname int_methods
351		setMethod("print", "VTableTree", function(x, ...) {
352	5x	msg <- toString(x, ...)
353	4x	cat(msg)
354	4x	invisible(x)
355		})
356
357		#' @rdname int_methods
358		setMethod("show", "VTableTree", function(object) {
359	!	cat(toString(object))
360	!	invisible(object)
361		})
362
363		setMethod("show", "TableRow", function(object) {
364	1x	cat(sprintf(
365	1x	"[%s indent_mod %d]: %s %s\n",
366	1x	class(object),
367	1x	indent_mod(object),
368	1x	obj_label(object),
369	1x	paste(as.vector(get_formatted_cells(object)),
370	1x	collapse = " "
371		)
372		))
373	1x	invisible(object)
374		})

1		## NB handling the case where there are no values is done during tabulation
2		## which is the only reason expression(TRUE) is ok, because otherwise
3		## we (sometimes) run into
4		## factor()[TRUE] giving <NA> (i.e. length 1)
5	4313x	setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))
6
7		setMethod(
8		"make_subset_expr", "VarLevelSplit",
9		function(spl, val) {
10		## this is how custom split functions will communicate the correct expression
11		## to the column modeling code
12	3194x	if (length(value_expr(val)) > 0) {
13	12x	return(value_expr(val))
14		}
15
16	3182x	v <- unlist(rawvalues(val))
17		## XXX if we're including all levels should even missing be included?
18	3182x	if (is(v, "AllLevelsSentinel")) {
19	9x	as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl)))))
20		} else {
21	3173x	as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(
22	3173x	a = as.name(spl_payload(spl)),
23	3173x	b = v
24		)))
25		}
26		}
27		)
28
29		setMethod(
30		"make_subset_expr", "MultiVarSplit",
31		function(spl, val) {
32		## this is how custom split functions will communicate the correct expression
33		## to the column modeling code
34	300x	if (length(value_expr(val)) > 0) {
35	!	return(value_expr(val))
36		}
37
38		## v = rawvalues(val)
39		## as.expression(bquote(!is.na(.(a)), list(a = v)))
40	300x	expression(TRUE)
41		}
42		)
43
44		setMethod(
45		"make_subset_expr", "AnalyzeVarSplit",
46		function(spl, val) {
47	!	if (avar_inclNAs(spl)) {
48	!	expression(TRUE)
49		} else {
50	!	as.expression(bquote(
51	!	!is.na(.(a)),
52	!	list(a = as.name(spl_payload(spl)))
53		))
54		}
55		}
56		)
57
58		setMethod(
59		"make_subset_expr", "AnalyzeColVarSplit",
60		function(spl, val) {
61	!	expression(TRUE)
62		}
63		)
64
65		## XXX these are going to be ridiculously slow
66		## FIXME
67
68		setMethod(
69		"make_subset_expr", "VarStaticCutSplit",
70		function(spl, val) {
71	135x	v <- rawvalues(val)
72		## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels),
73	135x	as.expression(bquote(
74	135x	cut(.(a),
75	135x	breaks = .(brk), labels = .(labels),
76	135x	include.lowest = TRUE
77	135x	) == .(b),
78	135x	list(
79	135x	a = as.name(spl_payload(spl)),
80	135x	b = v,
81	135x	brk = spl_cuts(spl),
82	135x	labels = spl_cutlabels(spl)
83		)
84		))
85		}
86		)
87
88		## NB this assumes spl_cutlabels(spl) is in order!!!!!!
89		setMethod(
90		"make_subset_expr", "CumulativeCutSplit",
91		function(spl, val) {
92	63x	v <- rawvalues(val)
93		## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk),
94	63x	as.expression(bquote(
95	63x	as.integer(cut(.(a),
96	63x	breaks = .(brk),
97	63x	labels = .(labels),
98	63x	include.lowest = TRUE
99		)) <=
100	63x	as.integer(factor(.(b), levels = .(labels))),
101	63x	list(
102	63x	a = as.name(spl_payload(spl)),
103	63x	b = v,
104	63x	brk = spl_cuts(spl),
105	63x	labels = spl_cutlabels(spl)
106		)
107		))
108		}
109		)
110
111		## I think this one is unnecessary,
112		## build_table collapses DynCutSplits into
113		## static ones.
114		##
115		## XXX TODO fixme
116		## setMethod("make_subset_expr", "VarDynCutSplit",
117		## function(spl, val) {
118		## v = rawvalues(val)
119		## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)),
120		## as.expression(bquote(.(fun)(.(a)) == .(b)),
121		## list(a = as.name(spl_payload(spl)),
122		## b = v,
123		## fun = spl@cut_fun))
124		## })
125
126		setMethod(
127		"make_subset_expr", "AllSplit",
128	327x	function(spl, val) expression(TRUE)
129		)
130
131		## probably don't need this
132
133		setMethod(
134		"make_subset_expr", "expression",
135	!	function(spl, val) spl
136		)
137
138		setMethod(
139		"make_subset_expr", "character",
140		function(spl, val) {
141	!	newspl <- VarLevelSplit(spl, spl)
142	!	make_subset_expr(newspl, val)
143		}
144		)
145
146		.combine_subset_exprs <- function(ex1, ex2) {
147	2934x	if (is.null(ex1) \|\| identical(ex1, expression(TRUE))) {
148	1864x	if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
149	1419x	return(ex2)
150		} else {
151	445x	return(expression(TRUE))
152		}
153		}
154
155		## if(is.null(ex2))
156		## ex2 <- expression(TRUE)
157	1070x	stopifnot(is.expression(ex1), is.expression(ex2))
158	1070x	as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))
159		}
160
161		make_pos_subset <- function(spls = pos_splits(pos),
162		svals = pos_splvals(pos),
163		pos) {
164	1003x	expr <- NULL
165	1003x	for (i in seq_along(spls)) {
166	1555x	newexpr <- make_subset_expr(spls[[i]], svals[[i]])
167	1555x	expr <- .combine_subset_exprs(expr, newexpr)
168		}
169	1003x	expr
170		}
171
172		get_pos_extra <- function(svals = pos_splvals(pos),
173		pos) {
174	1009x	ret <- list()
175	1009x	for (i in seq_along(svals)) {
176	1567x	extrs <- splv_extra(svals[[i]])
177	1567x	if (any(names(ret) %in% names(extrs))) {
178	!	stop("same extra argument specified at multiple levels of nesting. Not currently supported")
179		}
180	1567x	ret <- c(ret, extrs)
181		}
182	1009x	ret
183		}
184
185		get_col_extras <- function(ctree) {
186	320x	leaves <- collect_leaves(ctree)
187	320x	lapply(
188	320x	leaves,
189	320x	function(x) get_pos_extra(pos = tree_pos(x))
190		)
191		}
192
193		setGeneric(
194		"make_col_subsets",
195	1322x	function(lyt, df) standardGeneric("make_col_subsets")
196		)
197
198		setMethod(
199		"make_col_subsets", "LayoutColTree",
200		function(lyt, df) {
201	319x	leaves <- collect_leaves(lyt)
202	319x	lapply(leaves, make_col_subsets)
203		}
204		)
205
206		setMethod(
207		"make_col_subsets", "LayoutColLeaf",
208		function(lyt, df) {
209	1003x	make_pos_subset(pos = tree_pos(lyt))
210		}
211		)
212
213		create_colinfo <- function(lyt, df, rtpos = TreePos(),
214		counts = NULL,
215		alt_counts_df = NULL,
216		total = NULL,
217		topleft = NULL) {
218		## this will work whether clayout is pre or post
219		## data
220	325x	clayout <- clayout(lyt)
221	325x	if (is.null(topleft)) {
222	325x	topleft <- top_left(lyt)
223		}
224	325x	cc_format <- colcount_format(lyt) %\|\|% "(N=xx)"
225
226		## do it this way for full backwards compatibility
227	325x	if (is.null(alt_counts_df)) {
228	306x	alt_counts_df <- df
229		}
230	325x	ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format)
231	318x	if (!is.na(disp_ccounts(lyt))) {
232	81x	leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path
233	81x	for (path in leaf_pths) {
234	323x	colcount_visible(ctree, path) <- disp_ccounts(lyt)
235		}
236		}
237
238	318x	cexprs <- make_col_subsets(ctree, df)
239	318x	colextras <- col_extra_args(ctree)
240
241		## calculate the counts based on the df
242		## This presumes that it is called on the WHOLE dataset,
243		## NOT after any splitting has occurred. Otherwise
244		## the counts will obviously be wrong.
245	318x	if (is.null(counts)) {
246	314x	counts <- rep(NA_integer_, length(cexprs))
247	4x	} else if (length(counts) != length(cexprs)) {
248	1x	stop(
249	1x	"Length of overriding counts must equal number of columns. Got ",
250	1x	length(counts), " values for ", length(cexprs), " columns. ",
251	1x	"Use NAs to specify that the default counting machinery should be ",
252	1x	"used for that position."
253		)
254		}
255
256	317x	counts_df_name <- "alt_counts_df"
257	317x	if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
258	302x	alt_counts_df <- df
259	302x	counts_df_name <- "df"
260		}
261	317x	calcpos <- is.na(counts)
262
263	317x	calccounts <- sapply(cexprs, function(ex) {
264	994x	if (identical(ex, expression(TRUE))) {
265	149x	nrow(alt_counts_df)
266	845x	} else if (identical(ex, expression(FALSE))) {
267	!	0L
268		} else {
269	845x	vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)
270	845x	if (is(vec, "numeric")) {
271	!	length(vec)
272	845x	} else if (is(vec, "logical")) { ## sum(is.na(.)) ????
273	845x	sum(vec, na.rm = TRUE)
274		}
275		}
276		})
277	317x	counts[calcpos] <- calccounts[calcpos]
278	317x	counts <- as.integer(counts)
279	317x	if (is.null(total)) {
280	!	total <- sum(counts)
281		}
282
283	317x	cpths <- col_paths(ctree)
284	317x	for (i in seq_along(cpths)) {
285	994x	facet_colcount(ctree, cpths[[i]]) <- counts[i]
286		}
287	317x	InstantiatedColumnInfo(
288	317x	treelyt = ctree,
289	317x	csubs = cexprs,
290	317x	extras = colextras,
291	317x	cnts = counts,
292	317x	dispcounts = disp_ccounts(lyt),
293	317x	countformat = cc_format,
294	317x	total_cnt = total,
295	317x	topleft = topleft
296		)
297		}

1		#' Compare two rtables
2		#'
3		#' Prints a matrix where `.` means cell matches, `X` means cell does
4		#' not match, `+` cell (row) is missing, and `-` cell (row)
5		#' should not be there. If `structure` is set to `TRUE`, `C` indicates
6		#' column-structure mismatch, `R` indicates row-structure mismatch, and
7		#' `S` indicates mismatch in both row and column structure.
8		#'
9		#' @param object (`VTableTree`)\cr `rtable` to test.
10		#' @param expected (`VTableTree`)\cr expected `rtable`.
11		#' @param tol (`numeric(1)`)\cr tolerance.
12		#' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are
13		#' silently ignored.
14		#' @param structure (`flag`)\cr whether structures (in the form of column and row
15		#' paths to cells) should be compared. Currently defaults to `FALSE`, but this is
16		#' subject to change in future versions.
17		#'
18		#' @note In its current form, `compare_rtables` does not take structure into
19		#' account, only row and cell position.
20		#'
21		#' @return A matrix of class `rtables_diff` representing the differences
22		#' between `object` and `expected` as described above.
23		#'
24		#' @examples
25		#' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
26		#' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
27		#'
28		#' compare_rtables(object = t1, expected = t2)
29		#'
30		#' if (interactive()) {
31		#' Viewer(t1, t2)
32		#' }
33		#'
34		#' expected <- rtable(
35		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
36		#' format = "xx",
37		#' rrow("row 1", 10, 15),
38		#' rrow(),
39		#' rrow("section title"),
40		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
41		#' )
42		#'
43		#' expected
44		#'
45		#' object <- rtable(
46		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
47		#' format = "xx",
48		#' rrow("row 1", 10, 15),
49		#' rrow("section title"),
50		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
51		#' )
52		#'
53		#' compare_rtables(object, expected, comp.attr = FALSE)
54		#'
55		#' object <- rtable(
56		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
57		#' format = "xx",
58		#' rrow("row 1", 10, 15),
59		#' rrow(),
60		#' rrow("section title")
61		#' )
62		#'
63		#' compare_rtables(object, expected)
64		#'
65		#' object <- rtable(
66		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
67		#' format = "xx",
68		#' rrow("row 1", 14, 15.03),
69		#' rrow(),
70		#' rrow("section title"),
71		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
72		#' )
73		#'
74		#' compare_rtables(object, expected)
75		#'
76		#' object <- rtable(
77		#' header = c("ARM A\nN=100", "ARM B\nN=200"),
78		#' format = "xx",
79		#' rrow("row 1", 10, 15),
80		#' rrow(),
81		#' rrow("section title"),
82		#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
83		#' )
84		#'
85		#' compare_rtables(object, expected)
86		#'
87		#' @export
88		compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,
89		structure = FALSE) {
90		# if (identical(object, expected)) return(invisible(TRUE))
91
92	12x	if (!is(object, "VTableTree")) {
93	!	stop(
94	!	"argument object is expected to be of class TableTree or ",
95	!	"ElementaryTable"
96		)
97		}
98	12x	if (!is(expected, "VTableTree")) {
99	!	stop(
100	!	"argument expected is expected to be of class TableTree or ",
101	!	"ElementaryTable"
102		)
103		}
104	12x	dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)
105
106	12x	X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
107	12x	row.names(X) <- as.character(1:dim_out[1])
108	12x	colnames(X) <- as.character(1:dim_out[2])
109
110	12x	if (!identical(names(object), names(expected))) {
111	7x	attr(X, "info") <- "column names are not the same"
112		}
113
114	12x	if (!comp.attr) {
115	!	attr(X, "info") <- c(
116	!	attr(X, "info"),
117	!	"cell attributes have not been compared"
118		)
119		}
120	12x	if (!identical(row.names(object), row.names(expected))) {
121	2x	attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")
122		}
123
124	12x	nro <- nrow(object)
125	12x	nre <- nrow(expected)
126	12x	nco <- ncol(object)
127	12x	nce <- ncol(expected)
128
129	12x	if (nco < nce) {
130	2x	X[, seq(nco + 1, nce)] <- "-"
131	10x	} else if (nce < nco) {
132	3x	X[, seq(nce + 1, nco)] <- "+"
133		}
134	12x	if (nro < nre) {
135	1x	X[seq(nro + 1, nre), ] <- "-"
136	11x	} else if (nre < nro) {
137	!	X[seq(nre + 1, nro), ] <- "+"
138		}
139
140	12x	orig_object <- object # nolint
141	12x	orig_expected <- expected # nolint
142	12x	if (nro != nre \|\| nco != nce) {
143	5x	object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
144	5x	expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]
145	5x	inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)
146	5x	X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner
147	5x	class(X) <- c("rtables_diff", class(X))
148	5x	return(X)
149		}
150
151		## from here dimensions match!
152
153	7x	orows <- cell_values(object, omit_labrows = FALSE)
154	7x	erows <- cell_values(expected, omit_labrows = FALSE)
155	7x	if (nrow(object) == 1) {
156	!	orows <- list(orows)
157	!	erows <- list(erows)
158		}
159	7x	res <- mapply(compare_rrows,
160	7x	row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),
161	7x	USE.NAMES = FALSE, SIMPLIFY = FALSE
162		)
163	7x	X <- do.call(rbind, res)
164	7x	rpo <- row_paths(object)
165	7x	rpe <- row_paths(expected)
166
167	7x	if (comp.attr) {
168	7x	ofmts <- value_formats(object)
169	7x	efmts <- value_formats(expected)
170		## dim(ofmts) <- NULL
171		## dim(efmts) <- NULL
172
173	7x	fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim
174
175
176		## note the single index here!!!, no comma!!!!
177	7x	X[fmt_mismatch] <- "X"
178		}
179
180
181	7x	if (structure) {
182	1x	rp_mismatches <- !mapply(identical, x = rpo, y = rpe)
183	1x	cpo <- col_paths(object)
184	1x	cpe <- col_paths(expected)
185	1x	cp_mismatches <- !mapply(identical, x = cpo, y = cpe)
186
187	1x	if (any(rp_mismatches)) { # P for (row or column) path do not match
188	!	X[rp_mismatches, ] <- "R"
189		}
190	1x	if (any(cp_mismatches)) {
191	1x	crep <- rep("C", nrow(X))
192	1x	if (any(rp_mismatches)) {
193	!	crep[rp_mismatches] <- "P"
194		}
195	1x	X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))
196		}
197		}
198	7x	class(X) <- c("rtables_diff", class(X))
199	7x	X
200		}
201
202		## for (i in 1:dim(X)[1]) {
203		## for (j in 1:dim(X)[2]) {
204
205		## is_equivalent <- TRUE
206		## if (i <= nro && i <= nre && j <= nco && j <= nce) {
207		## x <- object[i,j, drop = TRUE]
208		## y <- expected[i,j, drop = TRUE]
209
210		## attr_x <- attributes(x)
211		## attr_y <- attributes(y)
212
213		## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]
214		## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]
215
216		## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
217		## is_equivalent <- FALSE
218		## } else if (is.numeric(x) && is.numeric(y)) {
219		## if (any(abs(na.omit(x - y)) > tol)) {
220		## is_equivalent <- FALSE
221		## }
222		## } else {
223		## if (!identical(x, y)) {
224		## is_equivalent <- FALSE
225		## }
226		## }
227
228		## if (!is_equivalent) {
229		## X[i,j] <- "X"
230		## }
231		## } else if (i > nro \|\| j > nco) {
232		## ## missing in object
233		## X[i, j] <- "+"
234		## } else {
235		## ## too many elements
236		## X[i, j] <- "-"
237		## }
238		## }
239		## }
240		## class(X) <- c("rtable_diff", class(X))
241		## X
242		## }
243
244		compare_value <- function(x, y, tol) {
245	359x	if (identical(x, y) \|\| (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
246		"."
247		} else {
248	72x	"X"
249		}
250		}
251
252		compare_rrows <- function(row1, row2, tol, ncol) {
253	173x	if (length(row1) == ncol && length(row2) == ncol) {
254	115x	mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)
255	58x	} else if (length(row1) == 0 && length(row2) == 0) {
256	44x	rep(".", ncol)
257		} else {
258	14x	rep("X", ncol)
259		}
260		}
261
262		## #' @export
263		## print.rtable_diff <- function(x, ...) {
264		## print.default(unclass(x), quote = FALSE, ...)
265		## }

1		#' Default tabulation
2		#'
3		#' This function is used when [analyze()] is invoked.
4		#'
5		#' @param x (`vector`)\cr the already split data being tabulated for a particular cell/set of cells.
6		#' @param ... additional parameters to pass on.
7		#'
8		#' @details This function has the following behavior given particular types of inputs:
9		#' \describe{
10		#' \item{numeric}{calls [mean()] on `x`.}
11		#' \item{logical}{calls [sum()] on `x`.}
12		#' \item{factor}{calls [length()] on `x`.}
13		#' }
14		#'
15		#' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error.
16		#'
17		#' @inherit in_rows return
18		#'
19		#' @author Gabriel Becker and Adrian Waddell
20		#'
21		#' @examples
22		#' simple_analysis(1:3)
23		#' simple_analysis(iris$Species)
24		#' simple_analysis(iris$Species == "setosa")
25		#'
26		#' @rdname rtinner
27		#' @export
28	1304x	setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))
29
30		#' @rdname rtinner
31		#' @exportMethod simple_analysis
32		setMethod(
33		"simple_analysis", "numeric",
34	966x	function(x, ...) in_rows("Mean" = rcell(mean(x, ...), format = "xx.xx"))
35		)
36
37		#' @rdname rtinner
38		#' @exportMethod simple_analysis
39		setMethod(
40		"simple_analysis", "logical",
41	4x	function(x, ...) in_rows("Count" = rcell(sum(x, ...), format = "xx"))
42		)
43
44		#' @rdname rtinner
45		#' @exportMethod simple_analysis
46		setMethod(
47		"simple_analysis", "factor",
48	334x	function(x, ...) in_rows(.list = as.list(table(x)))
49		)
50
51		#' @rdname rtinner
52		#' @exportMethod simple_analysis
53		setMethod(
54		"simple_analysis", "ANY",
55		function(x, ...) {
56	!	stop("No default simple_analysis behavior for class ", class(x), " please specify FUN explicitly.")
57		}
58		)
59
60		#' Check if an object is a valid `rtable`
61		#'
62		#' @param x (`ANY`)\cr an object.
63		#'
64		#' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise.
65		#'
66		#' @examples
67		#' is_rtable(build_table(basic_table(), iris))
68		#'
69		#' @export
70		is_rtable <- function(x) {
71	47x	is(x, "VTableTree")
72		}
73
74		# nocov start
75		## is each object in a collection from a class
76		are <- function(object_collection, class2) {
77		all(vapply(object_collection, is, logical(1), class2))
78		}
79
80		num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
81		stopifnot(is.numeric(x))
82
83		if (length(x) == 1) {
84		return(TRUE)
85		}
86
87		y <- range(x) / mean(x)
88		isTRUE(all.equal(y[1], y[2], tolerance = tol))
89		}
90
91		# copied over from utils.nest which is not open-source
92		all_true <- function(lst, fcn, ...) {
93		all(vapply(lst, fcn, logical(1), ...))
94		}
95
96		is_logical_single <- function(x) {
97		!is.null(x) &&
98		is.logical(x) &&
99		length(x) == 1 &&
100		!is.na(x)
101		}
102
103		is_logical_vector_modif <- function(x, min_length = 1) {
104		!is.null(x) &&
105		is.logical(x) &&
106		is.atomic(x) &&
107		!anyNA(x) &&
108		ifelse(min_length > 0, length(x) >= min_length, TRUE)
109		}
110		# nocov end
111
112		# Shorthand for functions that take df as first parameter
113		.takes_df <- function(f) {
114	1585x	func_takes(f, "df", is_first = TRUE)
115		}
116
117		# Checking if function takes parameters
118		func_takes <- function(func, params, is_first = FALSE) {
119	10852x	if (is.list(func)) {
120	2256x	return(lapply(func, func_takes, params = params, is_first = is_first))
121		}
122	8596x	if (is.null(func) \|\| !is(func, "function")) {
123		# safe-net: should this fail instead?
124	1752x	return(setNames(rep(FALSE, length(params)), params))
125		}
126	6844x	f_params <- formals(func)
127	6844x	if (!is_first) {
128	2265x	return(setNames(params %in% names(f_params), params))
129		} else {
130	4579x	if (length(params) > 1L) {
131	1x	stop("is_first works only with one parameters.")
132		}
133	4578x	return(!is.null(f_params) && names(f_params)[1] == params)
134		}
135		}
136
137		#' Translate spl_context to a path to display in error messages
138		#'
139		#' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred.
140		#'
141		#' @return A character string containing a description of the row path corresponding to `ctx`.
142		#'
143		#' @export
144		spl_context_to_disp_path <- function(ctx) {
145		## this can happen in the first split in column space, but
146		## should never happen in row space
147	20x	if (length(ctx$split) == 0) {
148	2x	return("root")
149		}
150	18x	if (ctx$split[1] == "root" && ctx$value[1] == "root") {
151	17x	ctx <- ctx[-1, ]
152		}
153	18x	ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
154	18x	collapse = "->"
155		)
156	18x	if (length(ret) == 0 \|\| nchar(ret) == 0) {
157	11x	ret <- "root"
158		}
159	18x	ret
160		}
161
162		# Utility function to paste vector of values in a nice way
163		paste_vec <- function(vec) {
164	7x	paste0('c("', paste(vec, collapse = '", "'), '")')
165		}
166
167		# Utility for checking if a package is installed
168		check_required_packages <- function(pkgs) {
169	!	for (pkgi in pkgs) {
170	!	if (!requireNamespace(pkgi, quietly = TRUE)) {
171	!	stop(
172	!	"This function requires the ", pkgi, " package. ",
173	!	"Please install it if you wish to use it"
174		)
175		}
176		}
177		}

1		#' @importFrom utils browseURL
2		NULL
3
4		#' Display an `rtable` object in the Viewer pane in RStudio or in a browser
5		#'
6		#' The table will be displayed using bootstrap styling.
7		#'
8		#' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package).
9		#' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`.
10		#' @param ... arguments passed to [as_html()].
11		#'
12		#' @return Not meaningful. Called for the side effect of opening a browser or viewer pane.
13		#'
14		#' @examples
15		#' if (interactive()) {
16		#' sl5 <- factor(iris$Sepal.Length > 5,
17		#' levels = c(TRUE, FALSE),
18		#' labels = c("S.L > 5", "S.L <= 5")
19		#' )
20		#'
21		#' df <- cbind(iris, sl5 = sl5)
22		#'
23		#' lyt <- basic_table() %>%
24		#' split_cols_by("sl5") %>%
25		#' analyze("Sepal.Length")
26		#'
27		#' tbl <- build_table(lyt, df)
28		#'
29		#' Viewer(tbl)
30		#' Viewer(tbl, tbl)
31		#'
32		#'
33		#' tbl2 <- htmltools::tags$div(
34		#' class = "table-responsive",
35		#' as_html(tbl, class_table = "table")
36		#' )
37		#'
38		#' Viewer(tbl, tbl2)
39		#' }
40		#' @export
41		Viewer <- function(x, y = NULL, ...) {
42	3x	check_convert <- function(x, name, accept_NULL = FALSE) {
43	6x	if (accept_NULL && is.null(x)) {
44	3x	NULL
45	3x	} else if (is(x, "shiny.tag")) {
46	!	x
47	3x	} else if (is(x, "VTableTree")) {
48	3x	as_html(x, ...)
49		} else {
50	!	stop("object of class rtable or shiny tag excepted for ", name)
51		}
52		}
53
54	3x	x_tag <- check_convert(x, "x", FALSE)
55	3x	y_tag <- check_convert(y, "y", TRUE)
56
57	3x	html_output <- if (is.null(y)) {
58	3x	x_tag
59		} else {
60	!	tags$div(class = "container-fluid", htmltools::tags$div(
61	!	class = "row",
62	!	tags$div(class = "col-xs-6", x_tag),
63	!	tags$div(class = "col-xs-6", y_tag)
64		))
65		}
66
67	3x	sandbox_folder <- file.path(tempdir(), "rtable")
68
69	3x	if (!dir.exists(sandbox_folder)) {
70	1x	dir.create(sandbox_folder, recursive = TRUE)
71	1x	pbs <- file.path(path.package(package = "rtables"), "bootstrap/")
72	1x	file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)
73		# list.files(sandbox_folder)
74		}
75
76		# get html name
77	3x	n_try <- 10000
78	3x	for (i in seq_len(n_try)) {
79	6x	htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
80
81	6x	if (!file.exists(htmlFile)) {
82	3x	break
83	3x	} else if (i == n_try) {
84	!	stop("too many html rtables created, restart your session")
85		}
86		}
87
88	3x	html_bs <- tags$html(
89	3x	lang = "en",
90	3x	tags$head(
91	3x	tags$meta(charset = "utf-8"),
92	3x	tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
93	3x	tags$meta(
94	3x	name = "viewport",
95	3x	content = "width=device-width, initial-scale=1"
96		),
97	3x	tags$title("rtable"),
98	3x	tags$link(
99	3x	href = "css/bootstrap.min.css",
100	3x	rel = "stylesheet"
101		)
102		),
103	3x	tags$body(
104	3x	html_output
105		)
106		)
107
108	3x	cat(
109	3x	paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
110	3x	file = htmlFile, append = FALSE
111		)
112
113	3x	viewer <- getOption("viewer")
114
115	3x	if (!is.null(viewer)) {
116	3x	viewer(htmlFile)
117		} else {
118	!	browseURL(htmlFile)
119		}
120		}

1		#' Create an `ElementaryTable` from a `data.frame`
2		#'
3		#' @param df (`data.frame`)\cr a data frame.
4		#'
5		#' @details
6		#' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column
7		#' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior
8		#' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique.
9		#'
10		#' @seealso [as_result_df()] for the inverse operation.
11		#'
12		#' @examples
13		#' df_to_tt(mtcars)
14		#'
15		#' @export
16		df_to_tt <- function(df) {
17	4x	colnms <- colnames(df)
18	4x	cinfo <- manual_cols(colnms)
19	4x	rnames <- rownames(df)
20	4x	havern <- !is.null(rnames)
21
22	4x	if ((!havern \|\| all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
23	2x	rnames <- df$label_name
24	2x	df <- df[, -match("label_name", colnms)]
25	2x	colnms <- colnames(df)
26	2x	cinfo <- manual_cols(colnms)
27	2x	havern <- TRUE
28		}
29
30	4x	kids <- lapply(seq_len(nrow(df)), function(i) {
31	124x	rni <- if (havern) rnames[i] else ""
32	124x	do.call(rrow, c(list(row.name = rni), unclass(df[i, ])))
33		})
34
35	4x	ElementaryTable(kids = kids, cinfo = cinfo)
36		}

1		#' @importFrom tools file_ext
2		NULL
3
4		#' Create enriched flat value table with paths
5		#'
6		#' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then
7		#' writes that data frame out as a `tsv` file.
8		#'
9		#' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are
10		#' collapsed to character vectors by collapsing the list element with `"\|"`.
11		#'
12		#' @note
13		#' There is currently no round-trip capability for this type of export. You can read values exported this way back in
14		#' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`.
15		#'
16		#' @inheritParams gen_args
17		#' @inheritParams data.frame_export
18		#' @param file (`string`)\cr the path of the file to written to or read from.
19		#' @param sep (`string`)\cr defaults to `\t`. See [utils::write.table()] for more details.
20		#' @param ... (`any`)\cr additional arguments to be passed to [utils::write.table()].
21		#'
22		#' @return
23		#' * `export_as_tsv` returns `NULL` silently.
24		#' * `import_from_tsv` returns a `data.frame` with re-constituted list values.
25		#'
26		#' @seealso [path_enriched_df()] for the underlying function that does the work.
27		#'
28		#' @importFrom utils write.table read.table
29		#' @rdname tsv_io
30		#' @export
31		export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path,
32		value_fun = collapse_values, sep = "\t", ...) {
33	1x	df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun)
34	1x	write.table(df, file, sep = sep, ...)
35		}
36
37		#' @rdname tsv_io
38		#' @export
39		import_from_tsv <- function(file) {
40	1x	rawdf <- read.table(file, header = TRUE, sep = "\t")
41	1x	as.data.frame(lapply(
42	1x	rawdf,
43	1x	function(col) {
44	7x	if (!any(grepl(.collapse_char, col, fixed = TRUE))) {
45	!	col
46		} else {
47	7x	I(strsplit(col, split = .collapse_char_esc))
48		}
49		}
50		))
51		}
52		# txt (formatters) --------------------------------------------------------------------
53		#' @importFrom formatters export_as_txt
54		#'
55		#' @examples
56		#' lyt <- basic_table() %>%
57		#' split_cols_by("ARM") %>%
58		#' analyze(c("AGE", "BMRKR2", "COUNTRY"))
59		#'
60		#' tbl <- build_table(lyt, ex_adsl)
61		#'
62		#' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8))
63		#'
64		#' \dontrun{
65		#' tf <- tempfile(fileext = ".txt")
66		#' export_as_txt(tbl, file = tf)
67		#' system2("cat", tf)
68		#' }
69		#'
70		#' @export
71		formatters::export_as_txt
72
73		# pdf (formatters) ----------------------------------------------------------
74		#' @importFrom formatters export_as_pdf
75		#'
76		#' @examples
77		#' lyt <- basic_table() %>%
78		#' split_cols_by("ARM") %>%
79		#' analyze(c("AGE", "BMRKR2", "COUNTRY"))
80		#'
81		#' tbl <- build_table(lyt, ex_adsl)
82		#'
83		#' \dontrun{
84		#' tf <- tempfile(fileext = ".pdf")
85		#' export_as_pdf(tbl, file = tf, pg_height = 4)
86		#' tf <- tempfile(fileext = ".pdf")
87		#' export_as_pdf(tbl, file = tf, lpp = 8)
88		#' }
89		#'
90		#' @export
91		formatters::export_as_pdf